.delphi

unit FUtil;

interface

uses

  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

  DB, DBTables, dbiProcs;

type

  TfrmFUtil = class(TForm)

  private

    { Private declarations }

  public

    { Public declarations }

  end;

var

  frmFUtil: TfrmFUtil;


Function  Padl( Texto:String ; Tam:Integer) : String;

Function  Padr( Texto:String ; Tam:Integer) : String;

Function  Padlzero( Texto:String ; Tam:Integer) : String;

Function  Extenso(pValor:Real) : String;

Function  fExtenso(nValor:Real):String;

Function  ExtensoMil(cVlr:string):String;

Function  LenNum(Numero:Real): Integer;

Function  RetiraMarca(cTexto,cMarca:String):String;

Function  MaskCPFCGC(cCPF:String):String;

Procedure AvisaErro(xTexto:String);

Procedure CopyRecord2(const SourceTable, DestTable : TTable);

Function cpf(cpf1 : string) : boolean;

Function cgc(cgc1 : string) : boolean;

Procedure PutStringVar(dbVaria:TTable;Chave:String;Valor:String);

Procedure PutFloatVar(dbVaria:TTable;Chave:String;Valor:Real);

Procedure PutIntegerVar(dbVaria:TTable;Chave:String;Valor:Integer);

Procedure PutBooleanVar(dbVaria:TTable;Chave:String;Valor:Boolean);

Function GetStringVar(dbVaria:TTable;Chave:String):String;

Function GetFloatVar(dbVaria:TTable;Chave:String):Real;

Function GetIntegerVar(dbVaria:TTable;Chave:String):Integer;

Function GetBooleanVar(dbVaria:TTable;Chave:String):Boolean;

Function MinFloat(Num1,Num2:Real):Real;

Function StrZero(Num:Double;Tam:byte):String;

Function REPLICATE(RepliStr: String; NoTimes: Byte): String;

Function Confirma(xTexto:String):Boolean ;

Function RetornaDia(Data:TDateTime):Word;

procedure ParadoxPack(Table : TTable);

function SomaMes(Data:TDateTime;Meses:Integer):TDateTime;

Function UltimoDiaMes(mes:word):word;

Procedure CopReg(Tabela1,Tabela2:TTable);

Function HDSerialNumber: String;

implementation

{$R *.DFM}


//=================================================================

  Procedure CopReg(Tabela1,Tabela2:TTable);

//=================================================================

var n:word;

    NomeCampo : String;

begin

   Tabela2.Append;;

   For n:=0 to (Tabela2.FieldCount-1) do begin

       NomeCampo := Tabela2.Fields[n].FieldName;

       Tabela2.FieldByName(NomeCampo).Value :=

       Tabela1.FieldByName(NomeCampo).Value;

       end;

   Tabela2.Post;

end;



//=================================================================

  Function RetornaDia(Data:TDateTime):Word;

//=================================================================

var dd,mm,aa :word;

begin

DecodeDate(Data,aa,mm,dd);

result := dd;

end;


//=================================================================

  Function SomaMes(Data:TDateTime;Meses:Integer):TDateTime;

//=================================================================

var dd,mm,aa,tt :word;

begin

DecodeDate(Data,aa,mm,dd);

tt := mm+meses-1  ;


aa := aa + (tt div 12);

mm := (tt mod 12) + 1;

if dd > UltimoDiaMes(mm)

   then dd := UltimoDIaMes(mm);

Result := EncodeDate(aa,mm,dd);

end;


//=================================================================

  Function UltimoDiaMes(mes:word):word;

//=================================================================

const udm : array[1..12] of word = (31,28,31,30,31,30,31,31,30,31,30,31);

begin

result := udm[mes];

end;


//=================================================================

  Function StrZero(Num:Double;Tam:byte):String;

//=================================================================

var Texto:String;

    PosDecimal:byte;

begin

Texto := FloatToSTrf(Num,ffGeneral,tam,0);

PosDecimal:=Pos(DecimalSeparator,Texto);

if PosDecimal > 0 then

   Texto := Copy(Texto,1,PosDecimal-1);

if Length(Texto) < Tam

   then Texto := Replicate('0',Tam-Length(Texto))+Texto;

Result := Texto;

end;

//=================================================================

  Function REPLICATE(RepliStr: String; NoTimes: Byte): String;

//=================================================================

Var

 i      : Byte;

 TempStr: String;

Begin

  TempStr:='';

  For i:= 1 To NoTimes Do TempStr:= TempStr + RepliStr;

  REPLICATE:= TempStr;

End;




//=================================================================

  Function MinFloat(Num1,Num2:Real):Real;

//=================================================================

begin

if Num1<=Num2 then result := Num1 else result := num2;

end;




//=================================================================

  Function RetiraMarca(cTexto,cMarca:String):String;

//=================================================================

  Var Conta:ShortInt;

   Begin

      For Conta:=1 to Length(cTexto) do

          if Pos(cTexto[Conta],cMarca)<=0 then

             Result := Result + cTexto[Conta];

   end;

//=================================================================

  Function MaskCPFCGC(cCPF:String):String;

//=================================================================

begin

     cCPF := RetiraMarca(cCPF,'.-+,();:\/');

     if Length(cCPF)>11

        Then Result := 

Copy(cCPF,1,2)+'.'+Copy(cCPF,3,3)+'.'+Copy(cCPF,6,3)+'/'+Copy(cCPF,9,4)+'-

'+Copy(cCPF,13,2)

        else Result := Copy(cCPF,1,3)+'.'+Copy(cCPF,4,3)+'.'+Copy(cCPF,7,3)+'-

'+Copy(cCPF,10,2);

end;



// =====================================================

   Procedure AvisaErro(xTexto:String) ;

// =====================================================

begin

   messageBeep(0);

   MessageDlg( xTexto,mtError, [mbOk],0 );

end;


// =====================================================

   Function Confirma(xTexto:String):Boolean ;

// =====================================================

begin

   messageBeep(0);

   if MessageDlg( xTexto,mtConfirmation, [mbYes,mbNo],0 )=mrYes

      then result:=true

      else result:=false;

end;




// =====================================================

   Function LenNum(Numero:Real): Integer;

// =====================================================

var cNumero : String ;

begin

cNumero := FormatFloat('0.000E+00', Numero);

Result :=  StrToInt(Copy(cNumero,Length(cNumero)-1,2))+1


{FloatToStrF(Numero; ffExponent; 14,2)}

end;


// =====================================================

   Function Padlzero( Texto:String ; Tam:Integer) : String;

// =====================================================

var tamtex,n : integer;

begin

     tamtex :=  Length(Texto);
 
    Result := Texto         ;

     if tamtex > tam then Result := Copy(Texto,tamtex-tam+1,tam);

     if tamtex < tam then For n:=tamtex to tam do Result := '0'+Result;

end;



// ======================================

   Function Extenso(pValor:Real) : String;

// ======================================


var nParte1,nParte2 : Real;

    xExt1,xExt2,xJuncao : String;


begin

nParte1:=Int(pValor)          ;

nParte2:=pValor - nParte1*100 ;

xExt1 := fExtenso(nParte1)    ;

xExt2 := fExtenso(nParte2)    ;

if ((Length(xExt1)=0) and (Length(xExt2)=0))

   then xExt1 := 'zero';


if xExt1 = 'um'

   then xExt1 := xExt1+' real'

   else if xExt1 <> '' then xExt1 := xExt1+' reais';


if Length(xExt2)>0

   then

   if xExt2 = 'um'

      then xExt2 := xExt2 + ' centavo'

      else xExt2 := xExt2 + ' centavos';


if ((Length(xExt1)=0) or (Length(xExt2)=0))

   then xJuncao := ''

   else xJuncao := ' e ';


Result := xExt1 + xJuncao + xExt2;


end;




// ======================================

   Function fExtenso(nValor:Real):String;

// ======================================

const

aExSS : array[1..8] of String = ('',' mil',' milhoes',' bilhoes',' trilhoes',
                           'quadrilhoes',' quinqualhoes',' sextalhoes');

aExSP : array[1..8] of String = ('',' mil',' milhao ',' bilhao ',' trilhao ',
                           ' quadrilhao ',' quinqualhao ',' sextalhao');

var


NumGrupos,n,nn : Integer;


cValor,tExtenso,xExtenso,cGrupo : String;


begin

   NumGrupos := ( (LenNum(nValor)+2) div 3) ;

   cValor := PadlZero(FloattoStr(nValor),NumGrupos*3);

   tExtenso := '';

   xExtenso := '';


   For n:=1 to NumGrupos do

       begin

          cGrupo := Copy(cValor,n*3-2,3) ;

          xExtenso :=  ExtensoMil(cGrupo);

          nn := NumGrupos-n+1;

          if Length(xExtenso)>0

             Then

             begin

               if cGrupo ='001'

                  then xExtenso := xExtenso + aExSS[nn]

                  else xExtenso := xExtenso + aExSP[nn];

               if Length(tExtenso)>0

                  then tExtenso := tExtenso + ' ';

               tExtenso := tExtenso + xExtenso;

             end;

       end;


   Result := tExtenso;

   end;


// ===========================

   Function ExtensoMil(cVlr:string):String;

// ===========================

Const

aExp : array[1..37] of String = (

'um','dois','tres','quatro','cinco','seis','sete','oito','nove','dez',

'onze','doze','treze','quatorze','quinze','dezesseis','dezessete',

'dezoito','dezenove','vinte','trinta','quarenta','cinquenta','sessenta',

'setenta','oitenta','noventa','cem','duzentos','trezentos','quatrocentos',

'quinhentos','seiscentos','setecentos','oitocentos','novecentos','cento'

);

var

c1,c2,c3 : String;

e1,e2,e3,cJuncao1,cJuncao2 : String;

n1,n2,n3,n23 : Integer;

begin

c1:=Copy(cVlr,1,1) ; c2:=Copy(cVlr,2,1) ; c3:=Copy(cVlr,3,1);

n1:=StrToInt(c1)   ; n2:=StrToInt(c2) ; n3 := StrToInt(c3);

e1:='' ; e2:='' ; e3:='';

n23 := StrToInt(c2+c3);

if n1 > 0

   then

   if ((n1=1)and ((n2+n3)>0))

      then e1 := aExP[37]

      else e1 := aExp[27+n1];

if n2 > 1

   then begin

        e2 := aExp[18+n2];

        if n3>0

           then e3 := aExp[n3];

        end

   else begin

        e2 := '';

        if n23 > 0

           then e3 := aExp[n23];

        end;

if ((n1=0) or (n23=0))

   then cJuncao1 := ''

   else cJuncao1 := ' e ' ;

if ((n2=0) or (n3=0))

   then cJuncao2 := ''

   else cJuncao2 := '';


Result := e1+cJuncao1+e2+cJuncao2+e3;


end;



Function Padl( Texto:String ; Tam:Integer) : String;

var tamtex,n : integer;

begin

     tamtex :=  Length(Texto);

     Result := Texto         ;

     if tamtex > tam then Result := Copy(Texto,tamtex-tam+1,tam);

     if tamtex < tam then For n:=tamtex to tam do Result := ' '+Result;

end;


Function Padr( Texto:String ; Tam:Integer) : String;

var tamtex,n : integer;

begin

     tamtex :=  Length(Texto);

     Result := Texto         ;

     if tamtex > tam then Result := Copy(Texto,1,tam);

     if tamtex < tam then For n:=tamtex to tam do Result := Result+' ';

end;


Procedure CopyRecord2(const SourceTable, DestTable : TTable);

var

   I : Word;

begin

  DestTable.Append;

  For I := 0 to SourceTable.FieldCount - 1 do

  DestTable.Fields[I].Assign(SourceTable.Fields[I]);

  DestTable.Post;

end;


//=================================================================

  Function cpf(cpf1 : string) : boolean;

//=================================================================

// Função desenvolvida por "Ednei P. Monteiro" 

// Alerada em 23/09 por Boanerges Junior


var

  controle : string;

  contini  : integer;

  contfim  : integer;

  ii       : byte;

  i        : byte;

  digito   : integer;

  soma     : integer;

  Digitos  : String  ;

begin

  Digitos  := Copy(Cpf1,10,2);

  controle := '';

  contini  := 2;

  contfim  := 10;

  digito := 0;

  for ii := 1 to 2 do

    begin

      soma := 0;

      for i := contini to contfim do

        begin

          soma := soma + strtoint(copy(cpf1, i - ii,1))*(contfim+1+ii-i)

        end;

      if ii = 2 then

        soma := soma + (2*digito);

      digito := (soma*10) mod 11;

      if digito = 10 then

        digito := 0;

      controle := controle + inttostr(digito);

      contini := 3;

      contfim := 11

    end;

    result := (controle=digitos)

  end;


//=================================================================

  Function cgc(cgc1 : string) : Boolean;

//=================================================================

var

  controle : string;

  ii       : byte;

  i        : byte;

  digito   : integer;

  soma     : integer;

  mult     : string;

  digitos  : string;

begin

  Digitos  := Copy(Cgc1,13,2);

  controle := '';

  mult     := '543298765432';

  digito := 0;


  for ii := 1 to 2 do

    begin

      soma := 0;

      for i := 1 to 12 do

        begin

          soma := soma + strtoint(copy(cgc1, i, 1)) * strtoint(copy(mult, i, 1));

        end;

      if ii = 2 then

        soma := soma + (2*digito);

      digito := (soma*10) mod 11;

      if digito = 10 then

        digito := 0;

      controle := controle + inttostr(digito);

      mult     := '654329876543';

    end;

//    result := controle

    result := (controle=digitos)

  end;




{============================================}

 Function GetStringVar(dbVaria:TTable;Chave:String):String;

 begin

    if not dbVaria.Active then dbVaria.Open;

     if dbVaria.Findkey([Chave,'S']) then

        Result := dbVaria.FieldByName('Valor').AsString // .AsString

        Else

        Result := '';

 end;

{============================================}

 Function GetFloatVar(dbVaria:TTable;Chave:String):Real;

 begin

    if not dbVaria.Active then dbVaria.Open;

     if dbVaria.Findkey([Chave,'F']) then

        Result := dbVaria.FieldByName('Valor').AsFloat

        Else

        Result := 0.00;

 end;


{============================================}

 Function GetIntegerVar(dbVaria:TTable;Chave:String):Integer;

 begin

    if not dbVaria.Active then dbVaria.Open;

     if dbVaria.Findkey([Chave,'I']) then

        Result := dbVaria['Valor'] // .AsInteger

        Else

        Result := 0;

 end;


{============================================}

 Function GetBooleanVar(dbVaria:TTable;Chave:String):Boolean;

 begin

    if not dbVaria.Active then dbVaria.Open;

     if dbVaria.Findkey([Chave,'B']) then

        Result := dbVaria['Valor'] // .AsBoolean

        Else

        Result := False;

 end;


{============================================}

 Procedure PutStringVar(dbVaria:TTable;Chave:String;Valor:String);

 begin

    if not dbVaria.Active then dbVaria.Open;

    if not dbVaria.FindKey([Chave,'S'])

       then dbVaria.append

       else dbVaria.edit;

       dbVaria.FieldByName('VarNome').AsString  := Chave;

       dbVaria.FieldByName('Tipo').AsString     := 'S';

       dbVaria.FieldByName('Valor').AsSTring    := Valor;

       dbVaria.Post;

 end;


{============================================}

 Procedure PutFloatVar(dbVaria:TTable;Chave:String;Valor:Real);

 begin

    if not dbVaria.Active then dbVaria.Open;

  if not  dbVaria.FindKey([Chave,'F'])

     then dbVaria.append

     else dbVaria.edit;

       dbVaria.FieldByName('VarNome').AsString := Chave;

       dbVaria.FieldByName('Tipo').AsString    := 'F';

       dbVaria.FieldByName('Valor').AsFloat    := Valor;

       dbVaria.Post;

 end;


{============================================}

 Procedure PutIntegerVar(dbVaria:TTable;Chave:String;Valor:Integer);

 begin

    if not dbVaria.Active then dbVaria.Open;

 if not  dbVaria.FindKey([Chave,'I'])

    then dbVaria.append

    else dbVaria.edit;

       dbVaria['VarNome']  //.AsString

              := Chave;

       dbVaria['Tipo']  //.AsString

              := 'I';

       dbVaria['Valor']  //.AsInteger

              := Valor;

       dbVaria.Post;

 end;


{============================================}

 Procedure PutBooleanVar(dbVaria:TTable;Chave:String;Valor:Boolean);

 begin

    if not dbVaria.Active then dbVaria.Open;

 if not  dbVaria.FindKey([Chave,'B'])

    then dbVaria.append

    else dbVaria.edit;

       dbVaria['VarNome']  //.AsString

               := Chave;

       dbVaria['Tipo']  // .AsString

               := 'B';

       dbVaria['Valor'] // .AsBoolean

               := Valor;

       dbVaria.Post;

 end;


  procedure ParadoxPack(Table : TTable); // by Bruno Sonnino 



  var

     TBDesc : CRTblDesc;

  begin

     FillChar(TBDesc,Sizeof(TBDesc),0);

     with TBDesc do begin

        StrPCopy(szTblName,Table.TableName);

        StrPCopy(szTblType,szParadox);

        bPack := True;

    end;

    Check(DBIDoRestructure(Table.DBHandle,1,@TBDesc,nil,nil,nil,False));

  end;

{============================================}

Function HDSerialNumber: String;

// Autor: Luiz Vaz

var

  a, b    : dword;

  R       : pdWord;

  Buffer  : array [0..255] of char;

begin

  GetMem(R, SizeOf(R));

  R^ := 0;

  Try

    GetVolumeInformation('c:\',Buffer,SizeOf(Buffer),R, a, b,nil,0);

    Result := IntToHex(R^, 8);

    Insert('-', Result, 5);

  except

    Result := '';

  end;

  FreeMem(R, SizeOf(R));

end;




end.

Clique aqui para voltar para a página inicial