Buscar

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;

 

Publicidade

Vote na dica




Quantidade de votos: 0 votos
Aceitação: 0%


Detalhes da dica

Categoria: Object pascal
Adicionada dia: 01/06/10
Por: Marcos Fernando Barbosa
Visualizada: 3892 vezes

Planeta Delphi - Tudo sobre programação Delphi Planeta Delphi - www.planetadelphi.com.br - Todos os direitos reservados | Copyright 2001-2009