Buscar por:

Pequenas funções para serem usadas de modo recursivo

Código

procedure MsgAdverte(Msg: String);

begin

  Application.MessageBox(PChar(Msg), 'Advertência', MB_OK + MB_ICONWARNING);

end;

procedure MsgInforma(Msg: String);

begin

  Application.MessageBox(PChar(Msg), 'Informação', MB_OK + MB_ICONINFORMATION);

end;

procedure MsgAvisa(Msg: String);

begin

  Application.MessageBox(PChar(Msg), 'Informação', MB_OK + MB_ICONINFORMATION);

end;

procedure MsgErro(Msg: String);

begin

  Application.MessageBox(PChar(Msg), 'Erro', MB_OK + MB_ICONERROR);

end;

function MsgConfirma(Msg: String): Boolean;

begin

  Result := (Application.MessageBox(PChar(Msg), 'Confirmação',

    MB_YESNO + MB_ICONQUESTION + MB_DEFBUTTON2) = idYes);

end;

function MesExtenso(Mes: Word) : string;

const

  meses : array[0..11] of PChar = ('Janeiro', 'Fevereiro', 'Março',

    'Abril', 'Maio', 'Junho', 'Julho', 'Agosto', 'Setembro','Outubro', 'Novembro', 'Dezembro');

begin

  result := meses[mes-1];

end;

function RemoveAcento(Str:String): String;

const

  ComAcento = 'àâêôûãõáéíóúçüÀÂÊÔÛÃÕÁÉÍÓÚÇÜ';

  SemAcento = 'aaeouaoaeioucuAAEOUAOAEIOUCU';

var

  x : Integer;

Begin

  for x := 1 to Length(Str) do begin

    if Pos(Str[x],ComAcento)<>0 then begin

      Str[x] := SemAcento[Pos(Str[x],ComAcento)];

    end;  

  end;  

  Result := Str;

end;

function soNumeros(Const Texto: String): String;

var

  I: integer;

  S: string;

begin

   S := '';

   for I := 1 To Length(Texto) Do begin

     if (Texto[I] in ['0'..'9']) then begin

       S := S + Copy(Texto, I, 1);

     end;

   end;

   result := S;

end;

function cpf(const CPF: string): boolean;

var

  I, Soma, Digito: integer;

  CalcCPF, S1, S2: string;

  B: boolean;

  C: Char;

begin

  Result := false;

  S1 := ''; { CPF somente com dígitos }

  for I := 1 to Length(CPF) do begin

    S2 := Copy(CPF, I, 1);

    if Pos(S2, '0123456789') > 0 then

      S1 := S1 + S2;

  end;

  if Length(S1) <> 11 then

    Exit; { Não é CPF, pois não são 11 dígitos }

  { Teste se os 11 díg. são iguais }

  B := true;

  C := S1[1];

  for I := 2 to 11 do begin

    B := B and (S1[I] = C);

    C := S1[I];

  end;

  if B then { Todos díg. iguais }

    Exit;

  CalcCPF := Copy(S1, 1, 9);

  { Cálculo do 1º dígito }

  Soma := 0;

  for I := 1 to 9 do

    Soma := Soma + StrToInt(Copy(CalcCPF, I, 1)) * (11 - I);

  Digito := 11 - (Soma mod 11);

  if Digito in [ 10, 11 ] then

    CalcCPF := CalcCPF + '0'

  else

    CalcCPF := CalcCPF + IntToStr(Digito);

  { Cálculo do 2º dígito }

  Soma := 0;

  for I := 1 to 10 do

    Soma := Soma + StrToInt(Copy(CalcCPF, I, 1)) * (12 - I);

  Digito := 11 - (Soma mod 11);

  if Digito in [ 10, 11 ] then

    CalcCPF := CalcCPF + '0'

  else

    CalcCPF := CalcCPF + IntToStr(Digito);

  if CalcCPF = S1 then

    Result := true;

end;

{ Retorna true se a string for um CGC válido }

function cgc(const CGC: string): boolean;

var

  CalcCGC, S1, S2: string;

  I, Soma, Digito: integer;

begin

  Result := false;

  S1 := ''; { CGC somente com dígitos }

  for I := 1 to Length(CGC) do begin

    S2 := Copy(CGC, I, 1);

    if Pos(S2, '0123456789') > 0 then

      S1 := S1 + S2;

  end;

  if Length(S1) <> 14 then

    Exit; { Não é CGC, pois não são 14 dígitos }

  if S1 = '00000000000000' then

    Exit;

  CalcCGC := Copy(S1, 1, 12);

  { Cálculo do 1º dígito }

  Soma := 0;

  for I := 1 to 4 do

    Soma := Soma + StrToInt(Copy(CalcCGC, I, 1)) * (6 - I);

  for I := 1 to 8 do

    Soma := Soma + StrToInt(Copy(CalcCGC, I + 4, 1)) * (10 - I);

  Digito := 11 - (Soma mod 11);

  if Digito in [ 10, 11 ] then

    CalcCGC := CalcCGC + '0'

  else

    CalcCGC := CalcCGC + IntToStr(Digito);

  { Cálculo do 2º dígito }

  Soma := 0;

  for I := 1 to 5 do

    Soma := Soma + StrToInt(Copy(CalcCGC, I, 1)) * (7 - I);

  for I := 1 to 8 do

    Soma := Soma + StrToInt(Copy(CalcCGC, I + 5, 1)) * (10 - I);

  Digito := 11 - (Soma mod 11);

  if Digito in [ 10, 11 ] then

    CalcCGC := CalcCGC + '0'

  else

    CalcCGC := CalcCGC + IntToStr(Digito);

  if CalcCGC = S1 then

    Result := true;

end;

Function AnoBissexto (ano: integer): boolean;

begin

if (((ano mod 4 = 0) and (ano mod 100 <> 0)) or (ano mod 400 = 0))

  then result := TRUE

  else result := FALSE;

end;

function RetiraPonto(S : string) : string;

var aux : string;

    i : integer;

begin

     aux := '';

     for i := 1 to Length(S) do

      begin

        if Copy(S,i,1) <> '.'

          then aux := aux+Copy(S,i,1);

      end;

     RetiraPonto := aux;

end;

function RetiraCaracteres(S : string) : string;

var aux : string;

    i : integer;

begin

     aux := '';

     for i := 1 to Length(S) do

      begin

        if (Copy(S,i,1) <> '/') and

           (Copy(S,i,1) <> '-') and

           (Copy(S,i,1) <> '.')

          then aux := aux+Copy(S,i,1);

      end;

     RetiraCaracteres := aux;

end;