uses Windows, SysUtils; function GetAge(ABirthday: TDateTime; ABase: TDateTime; var AYear: Integer; var AMonth: Integer; var ADate: Integer; var AWeek: Integer): Integer; var DT: TDateTime; ST1: TSystemTime; ST2: TSystemTime; ST3: TSystemTime; begin { Decode } DecodeDate(ABirthday,ST1.wYear,ST1.wMonth,ST1.wDay); DecodeDate(ABase,ST2.wYear,ST2.wMonth,ST2.wDay); AYear := ST2.wYear - ST1.wYear; AMonth := ST2.wMonth - ST1.wMonth; ADate := ST2.wDay - ST1.wDay; if (ST1.wMonth > ST2.wMonth) or ((ST1.wMonth = ST2.wMonth) and (ST1.wDay > ST2.wDay)) then begin AYear := AYear - 1; AMonth := AMonth + 12; end; { Regulate date } if ADate < 0 then begin AMonth := AMonth - 1; ST3.wYear := ST1.wYear + AYear; ST3.wMonth := ST1.wMonth + AMonth; ST3.wDay := ST1.wDay; if ST3.wMonth > 12 then begin ST3.wYear := ST3.wYear + 1; ST3.wMonth := ST3.wMonth - 12; end; DT := ABase; {$IFDEF CONDITIONALEXPRESSIONS} { Delphi 6 or later } while TryEncodeDate(ST3.wYear,ST3.wMonth,ST3.wDay,DT) = False do begin ST3.wDay := ST3.wDay - 1; end; {$ELSE} { Delphi 5 or before } repeat try DT := EncodeDate(ST3.wYear,ST3.wMonth,ST3.wDay); except ST3.wDay := ST3.wDay - 1; Continue; end; Break; until False; {$ENDIF} ADate := Trunc(ABase - DT); end; { Calc weeks } DT := ABase; ST3.wYear := ST1.wYear + AYear; ST3.wMonth := ST1.wMonth; ST3.wDay := ST1.wDay; {$IFDEF CONDITIONALEXPRESSIONS} { Delphi 6 or later } while TryEncodeDate(ST3.wYear,ST3.wMonth,ST3.wDay,DT) = False do begin ST3.wDay := ST3.wDay - 1; end; {$ELSE} { Delphi 5 or before } repeat try DT := EncodeDate(ST3.wYear,ST3.wMonth,ST3.wDay); except ST3.wDay := ST3.wDay - 1; Continue; end; Break; until False; {$ENDIF} AWeek := Trunc(ABase - DT) div 7; Result := AYear; end;
ABirthdayに誕生日、ABaseに基準日を渡すとAYear/AMonth/ADateに経過年/月/日数が、AYear/AWeekに経過年/週数が格納されます。
2010/12/16追記: 経過日数、経過週数の補正処理の部分で、Delphi 6以降({$IFDEF CONDITIONALEXPRESSIONS}で判別)ではEncodeDateの呼び出しとそこからの例外の送出ではなくTryEncodeDateとその戻値を使用するように変更しました。オリジナルのコードは以下に置いておきます。
uses Windows, SysUtils; function GetAge(ABirthday: TDateTime; ABase: TDateTime; var AYear: Integer; var AMonth: Integer; var ADate: Integer; var AWeek: Integer): Integer; var DT: TDateTime; ST1: TSystemTime; ST2: TSystemTime; ST3: TSystemTime; begin { Decode } DecodeDate(ABirthday,ST1.wYear,ST1.wMonth,ST1.wDay); DecodeDate(ABase,ST2.wYear,ST2.wMonth,ST2.wDay); AYear := ST2.wYear - ST1.wYear; AMonth := ST2.wMonth - ST1.wMonth; ADate := ST2.wDay - ST1.wDay; if (ST1.wMonth > ST2.wMonth) or ((ST1.wMonth = ST2.wMonth) and (ST1.wDay > ST2.wDay)) then begin AYear := AYear - 1; AMonth := AMonth + 12; end; { Regulate date } if ADate < 0 then begin AMonth := AMonth - 1; ST3.wYear := ST1.wYear + AYear; ST3.wMonth := ST1.wMonth + AMonth; ST3.wDay := ST1.wDay; if ST3.wMonth > 12 then begin ST3.wYear := ST3.wYear + 1; ST3.wMonth := ST3.wMonth - 12; end; DT := ABase; repeat try DT := EncodeDate(ST3.wYear,ST3.wMonth,ST3.wDay); except ST3.wDay := ST3.wDay - 1; Continue; end; Break; until False; ADate := Trunc(ABase - DT); end; { Calc weeks } DT := ABase; ST3.wYear := ST1.wYear + AYear; ST3.wMonth := ST1.wMonth; ST3.wDay := ST1.wDay; repeat try DT := EncodeDate(ST3.wYear,ST3.wMonth,ST3.wDay); except ST3.wDay := ST3.wDay - 1; Continue; end; Break; until False; AWeek := Trunc(ABase - DT) div 7; Result := AYear; end;
0 件のコメント:
コメントを投稿