Fórum Idade por Extenso? #298440

procedure Idade(Data1,Data2 : TDateTime; var Anos,Meses : Word);
var
  Ano2,Ano1,Mes2,Mes1,Dia2,Dia1 : Word;
begin
// decompõe a data nos componentes
  DecodeDate(Data2,Ano2,Mes2,Dia2);
  DecodeDate(Data1,Ano1,Mes1,Dia1);
// segundo dia menor que o primeiro - subtrai 1 mês
  if Dia2 < Dia1 then
    if Mes2 > 1 then
      Dec(Mes2)
    else begin
      Mes2 := 12;
      Dec(Ano2);
    end;
// segundo mês menor que o primeiro - subtrai 1 ano
// e soma 12 aos meses
  if Mes2 < Mes1 then begin
    Dec(Ano2);
    Inc(Mes2,12);
  end;
  Anos := Ano2-Ano1;
  Meses := Mes2-Mes1;  
end;

procedure TFRMCadfichas.MaskdatanascExit(Sender: TObject);
var
  Anos,Meses : word;
begin
  try
    Idade(StrToDate(Maskdatanasc.Text ), Date, Anos, Meses);
    //aqui o campo desejado recebe a idade na forma que vc quiser
    DBEditidadepac.Text := IntToStr(Anos)+´ A ´+IntToStr(meses)+´ M´;
  except
    On EConvertError do
      MessageDlg(´Data inválida´,mtError,[mbOk],0);
  end;
end;

unit Idade;

interface

uses
  SysUtils, Controls;

    function Idade2(DataNasc : TDate; var IdadeAno: integer) : String;

implementation

function Bissexto(AYear: Integer): Boolean;
begin
Result:=(AYear mod 4 = 0) and ((AYear mod 100 <> 0) or (AYear mod 400 = 0));
end;

function DiasDoMes(AYear, AMonth: Integer): Integer;
const
  DaysInMonth: array[1..12] of Integer = (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
begin
Result:=DaysInMonth[AMonth];
if (AMonth = 2) and Bissexto(AYear) then
    Inc(Result);
end;

function Idade2(DataNasc : TDate; var IdadeAno: integer) : String;
var
    Ano1, Mes1, Dia1 : Word;
    Ano2, Mes2, Dia2 : Word;
    Ano, Mes, Dia : Word;
    Idade : String;
    AuxDia1, AuxDia2: Integer;
begin
Idade:=´´;
DecodeDate(DataNasc, Ano1, Mes1, Dia1);
DecodeDate(Date, Ano2, Mes2, Dia2);
AuxDia1:=Dia1;
AuxDia2:=Dia2;
if (Dia1 > Dia2) And ((Mes2 - Mes1) = 1) then
    begin
    Dia2 := Dia2 + DiasDoMes(Ano1, Mes1);
    Mes1 := Mes2;
    end
else
    if (Dia1 > Dia2) And (Mes1 <> Mes2) then
        begin
        Dia2 := Dia2 + DiasDoMes(Ano1, Mes1);
        end
    else
        if (Mes1 = Mes2) And (Dia1 > Dia2) And (Ano1 <> Ano2) then
            begin
            Dia2 := Dia2 + DiasDoMes(Ano1, Mes1);
            Mes2 := Mes2 + 11;
            Ano1 := Ano1 + 1;
            end;
if (Mes1 > Mes2) And (AuxDia1 <= AuxDia2) then
    begin
    Ano1 := Ano1 + 1;
    Mes2 := Mes2 + 12;
    end
else
    if (Mes1 > Mes2) And (AuxDia1 > AuxDia2) then
        begin
        Ano1 := Ano1 + 1;
        Mes2 := Mes2 + 11;
        end;
Ano := Ano2 - Ano1;
IdadeAno:=Ano;
Mes := Mes2 - Mes1;
Dia := Dia2 - Dia1;
if Ano > 1 then
    Idade := IntToStr(Ano) + ´ Anos´
else
    if Ano = 1 then
        Idade := IntToStr(Ano) + ´ Ano´;
if Mes > 1 then
    Idade := Idade + ´, ´ + IntToStr(Mes) + ´ Meses ´
else
    if Mes <> 0 then
        Idade := Idade + ´, ´ + IntToStr(Mes) + ´ Mês ´;
If Ano = 0 then
    Delete(Idade, 1, 1);
if Dia > 1 then
    Idade := Idade + ´ e ´ + IntToStr(Dia) + ´ Dias´
else
    if Dia <> 0 then
        Idade := Idade + ´ e ´ + IntToStr(Dia) + ´ Dia´;
if (Mes = 0) And (Ano = 0) then
    Delete(Idade, 1, 3);
if (Ano1 = Ano2) And (Mes1 = Mes2) And (Dia1 > Dia2) then
    Idade := ´0´;
Result := Idade;
end;

function Idade1(Nasc : TDate) : String;
var
    AuxIdade, Meses, IdadeReal : String;
    MesesFloat : Real;
    IdadeInc : Integer;
begin
AuxIdade := Format(´¬0.2f´, [(Date - Nasc) / 365.6]);
Meses := FloatToStr(Frac(StrToFloat(AuxIdade)));
if AuxIdade = ´0´ then
    begin
    Result := ´0,0´;
    Exit;
    end;
if Meses[1] = ´-´ then
    Meses := FloatToStr(StrToFloat(Meses) * -1);
Delete(Meses, 1, 2);
if Length(Meses) = 1 then
    Meses := Meses + ´0´;
if (Meses <> ´0´) And (Meses <> ´´) then
    MesesFloat := Round(((365.6 * StrToInt(Meses)) / 100) / 30)
else
    MesesFloat := 0;
if MesesFloat <> 12 then
    IdadeReal := IntToStr(Trunc(StrToFloat(AuxIdade))) + ´,´ + FloatToStr(MesesFloat)
else
    begin
    IdadeInc := Trunc(StrToFloat(AuxIdade));
    Inc(IdadeInc);
    IdadeReal := IntToStr(IdadeInc) + ´,´ + ´0´;
    end;
Result := IdadeReal;
end;

end.