transdate.pas

公历与农历转换组件

//--------------------------------------------------------------------

constructor TTransDate.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FLunarDate := TLunarDate.Create(Self);
  FISO8601 := False;
  Date := DateOf(Now);
  FLunar_DateSeparator.sYear := '年';
  FLunar_DateSeparator.sMonth := '月';
  FLunar_DateSeparator.sDay := '日';
  FLunar_DateSeparator.sLeapMonth := '闰';
  FLunarDate.OnChange := FLunarDateChange;
  BookOfChanges := False;
end;

destructor TTransDate.Destroy;
begin
  FLunarDate.Free;
  inherited;
end;

{ TODO : Get Constellation }

function TTransDate.GetConstellation: string;
var
  ST: TSystemTime;
  D: Integer;
  CDay: Integer;
begin
  DateTimeToSystemTime(FDate, ST);
  CDay := ST.wMonth * 100 + ST.wDay;
  case CDay of
    120..218: D := 10;
    219..320: D := 11;
    321..419: D := 0;
    420..520: D := 1;
    521..620: D := 2;
    621..722: D := 3;
    723..822: D := 4;
    823..922: D := 5;
    923..1022: D := 6;
    1023..1121: D := 7;
    1122..1221: D := 8;
  else
    D := 9;
  end;
  Result := ConstellationName[D];
end;

{ TODO : Covert Greenwich Mean Time to Chinese traditional  calendar }

procedure TTransDate.DateToLunarDate(sDate: TDate; var LD: TLunarDate);
var
  SpanD: Integer;
  tmpD: Integer;
  Y, M, D: Integer;
  FL: Boolean;
begin
  SpanD := Round(DateOf(sDate)) - DateDelta;
  FL := False;
  if (SpanD < 31) then
  begin
    LD.FlYear := StartYear - 1;
    LD.FlMonth := 12;
    LD.lDay := SpanD;
    Exit;
  end
  else
    SpanD := SpanD - LunarDelta;

  Y := StartYear;
  M := 1;
  D := 1;
  tmpD := LunarYearDays(Y);
  while (SpanD >= tmpD) do
  begin
    SpanD := SpanD - tmpD;
    Y := Y + 1;
    tmpD := LunarYearDays(Y);
  end;
  while (SpanD >= (LunarMonthDays(Y, M) and $FFFF)) do
  begin
    SpanD := SpanD - (LunarMonthDays(Y, M) and $FFFF);
    if M = GetLeapMonth(Y) then
    begin
      if (SpanD < ((LunarMonthDays(Y, M) shr 16) and $FFFF)) then
      begin
        FL := True;
        break;
      end;
      SpanD := SpanD - ((LunarMonthDays(Y, M) shr 16) and $FFFF);
    end;
    M := M + 1;
  end;
  LD.FFLagLeapMonth := FL;
  LD.FlYear := Y;
  LD.FlMonth := M;
  LD.FlDay := SpanD + D;
end;

{ TODO : Covert Chinese traditional calendar to Greenwich Mean Time }

function TTransDate.LunarDateToDate(iDate: TLunarDate): TDate;
var
  tmpY, tmpM, tmpD: Integer;

  function DelMonth: Boolean;
  begin
    if tmpM = 1 then
    begin
      tmpM := 12;
      tmpY := tmpY - 1;
    end
    else
      tmpM := tmpM - 1;
    Result := tmpY >= StartYear;
  end;

begin
  with iDate do
  begin
    tmpY := FlYear;
    tmpM := FlMonth;
    tmpD := FlDay;
  end;
  Result := tmpD;
  if (tmpM = GetLeapMonth(tmpY)) and iDate.FFlagLeapMonth then
  begin
    Result := Result + LunarMonthDays(tmpY, tmpM) and $FFFF;
  end;
  if DelMonth then
    while (tmpY >= StartYear) and (tmpM >= 1) do
    begin
      Result := Result + (LunarMonthDays(tmpY, tmpM) shr 16) and $FFFF;
      Result := Result + LunarMonthDays(tmpY, tmpM) and $FFFF;
      if not DelMonth then
        Break;
    end;
  Result := Result + LunarDelta;
  if iDate.FlYear = StartYear then
    Result := Result - DaysInAYear(StartYear);
end;

 { TODO : Covert TLunar_Date to String }

function TTransDate.LunarDateToStr: string;
begin
  Result := '';
  with LunarDateSeparator, FLunarDate do
    if FLunarDate.FFLagLeapMonth then
      Result := Format('%d' + sYear + ' ' + sLeapMonth + '%d' + sMonth + ' ' +
        '%d' + sDay, [FlYear, FlMonth, FlDay])
    else
      Result := Format('%d' + sYear + ' ' + '%d' + sMonth + ' ' +
        '%d' + sDay, [FlYear, FlMonth, FlDay])
end;

procedure TTransDate.StrToLunarDate(DateStr: string; var LD: TLunarDate);
var
  DStr: string;
  function CutCopy(Delimiter: string; var SourceStr: string): string;
  type
    StrRec = packed record
      allocSiz: Longint;
      refCnt: Longint;
      length: Longint;
    end;
  const
    skew = sizeof(StrRec);
  var
    SourceStrAddr: Integer;
    ResultAddr: Integer;
    DelimiterLen: Integer;
  asm
        TEST    EAX,EAX
        JE      @@noWork

        TEST    EDX,EDX
        JE      @@noWork

        PUSH    EBX
        PUSH    ESI
        PUSH    EDI

        MOV     SourceStrAddr, EDX
        MOV     ResultAddr, ECX
        MOV     ESI,EAX

        MOV     EDI,[EDX]
        MOV     EDX,[ESI-skew].StrRec.length
        MOV     ECX,[EDI-skew].StrRec.length
        MOV     DelimiterLen, EDX

        PUSH    EDI

        DEC     EDX
        JS      @@fail
        MOV     AL,[ESI]
        INC     ESI
        SUB     ECX,EDX
        JLE     @@fail
    @@loop:
        REPNE   SCASB
        JNE     @@fail
        MOV     EBX,ECX
        PUSH    ESI
        PUSH    EDI
        MOV     ECX,EDX
        REPE    CMPSB
        POP     EDI
        POP     ESI
        JE      @@found
        MOV     ECX,EBX
        JMP     @@loop
    @@fail:
        POP     EDX
        JMP     @@exit
    @@found:
        POP     EDX
        MOV     EAX,EDI
        SUB     EAX,EDX

        DEC     EAX
        PUSH    EAX
        PUSH    EDX
        MOV     EDX, EAX
        MOV     EAX, ResultAddr
        CALL    system.@LStrSetLength
        MOV     EDI, [EAX]
        POP     ESI
        POP     ECX
        PUSH    ECX
        REP     MOVSB

        MOV     EAX, SourceStrAddr
        MOV     EDX, [EAX]
        MOV     ECX, [EDX-skew].StrRec.length
        POP     EAX
        SUB     ECX, EAX
        PUSH    ECX
        ADD     EAX, EDX
        ADD     EAX, DelimiterLen
        CALL    system.MOVE
        POP     EDX
        SUB     EDX, DelimiterLen
        MOV     EAX, SourceStrAddr
        CALL    system.@LstrSetLength

    @@exit:
        POP     EDI
        POP     ESI
        POP     EBX
    @@noWork:
  end;

begin
  DStr := DateStr;
  with LD, LunarDateSeparator do
  begin
    if Pos(LunarDateSeparator.sLeapMonth, DStr) > 0 then
      FlagLeapMonth := True
    else
      FlagLeapMonth := False;
    lYear := StrToInt(CutCopy(sYear, DStr));
    lMonth := StrToInt(CutCopy(sMonth, DStr));
    lDay := StrToInt(CutCopy(sDay, DStr));
    if ((LunarMonthDays(lYear, lMonth) shr 16) and $FFFF = 0) and LeapMonth then
      LeapMonth := False;
    if lDay > (LunarMonthDays(lYear, lMonth) and $FFFF) then
      lDay := LunarMonthDays(lYear, lMonth) and $FFFF;
  end;
end;

function TTransDate.GetLunar_DateSeparator: TLunar_DateSeparator;
begin
  Result := FLunar_DateSeparator;
end;

procedure TTransDate.SetLunar_DateSeparator(Value: TLunar_DateSeparator);
begin
  FLunar_DateSeparator := Value;
end;

function TTransDate.GetDate: TDate;
begin
  Result := FDate;
end;

{ TODO : SetFeast }

procedure TTransDate.SetFeast;
var
  Y, M, D: Word;

  procedure ReturnFeastsD(M: Word);
  var
    I: Integer;
  begin
    for I := Low(FeastsD) to High(FeastsD) do
      if (M = FeastsD[I].M) and (NthDayOfWeek(Fdate) = FeastsD[I].W) and (DayOfTheWeek(Fdate) = FeastsD[I].D) then
        FFeast := FFeast + FeastsD[I].N + ' ';
  end;

  procedure ReturnFeastsLD(Y, M, D: Word);
  var
    I: Integer;
  begin
    for I := Low(FeastsLD) to High(FeastsLD) do
      if (M = FeastsLD[I].M) and (D > (DaysInAMonth(Y, M) - 7)) and (DayOfTheWeek(EncodeDate(Y, M, D)) = FeastsLD[I].D) then
        FFeast := FFeast + FeastsLD[I].N + ' ';
  end;

  procedure ReturnEasterSunday(Y: Word);
  var
    I: Integer;
    tmpD: TDate;
    tmpLD: TLunarDate;
  begin
    if (FDate >= EncodeDate(Y, 3, 21)) and (Fdate <= EncodeDate(Y, 4, 25)) then
    begin
      tmpD := EncodeDate(Y, 3, 16);
      for I := 0 to Round((EncodeDate(Y, 4, 25) - EncodeDate(Y, 3, 21))) do
      begin
        if GetSolarTermD(tmpD) = 5 then
        begin
          tmpLD := TLunarDate.Create(nil);
          DateToLunarDate(tmpD, tmpLD);
          with tmpLD do
          begin
            if FlDay > 15 then
              tmpD := tmpD + GetMonthDays(FlYear, FlMonth) - FlDay + 15
            else
              tmpD := tmpD + 15 - tmpLD.FlDay;
            case DayOfWeek(tmpD) of
              1: tmpD := tmpD + 7;
              2..7: tmpD := tmpD + 7 - DayOfWeek(tmpD) + 1;
            end;
          end;
          tmpLD := nil;
          tmpLD.Free;
          Break;
        end;
        tmpD := tmpD + 1;
      end;
      if Round(FDate) = tmpD then
        FFeast := '复活节 Easter Sunday';
    end;
  end;

  procedure ReturnFeasts(Y, M, D: Word);
  var
    I: Integer;
  begin
    Y := (M shl 8) or D;
    for I := Low(Feasts) to High(Feasts) do
      if Feasts[I].M = Y then
      begin
        FFeast := FFeast + Feasts[I].N;
        Break;
      end;
  end;

  procedure ReturnThanksgivingDay(Y, M: Word);
    function ReturnLastFullWeek(Y, M: Word): Word;
    begin
      Result := NthDayOfWeek(EncodeDate(Y, M, DaysInAMonth(Y, M))) - 1;
    end;
  begin
    if (M = 11) and (WeekOfTheMonth(FDate) = ReturnLastFullWeek(Y, M)) and (DayOfTheWeek(FDate) = DayThursday) then
      FFeast := FFeast + '感恩节(United States) Thanksgiving Day ';
  end;

begin
  FFeast := '';
  DecodeDate(FDate, Y, M, D);
  ReturnEasterSunday(Y);
  ReturnThanksgivingDay(Y, M);
  ReturnFeastsD(M);
  ReturnFeastsLD(Y, M, D);
  ReturnFeasts(Y, M, D);
end;

procedure TTransDate.SetDate(Value: TDate);
begin
  if FDate <> Value then
  begin
    FDate := Value;
    DateToLunarDate(DateOf(FDate), FLunarDate);
    FLunarDate.SetLunD(FLunarDate);
    FMaxMonthDays := DaysInMonth(FDate);
    SetWeek;
    SetFeast;
    Change(Self);
  end;
end;

function TTransDate.GetLunarDate: TLunarDate;
begin
  Result := FLunarDate;
end;

procedure TTransDate.SetLunarDate(const Value: TLunarDate);
begin
  if FLunarDate <> Value then
  begin
    FLunarDate := Value;
    FDate := LunarDateToDate(Value);
    FMaxMonthDays := DaysInMonth(FDate);
    FLunarDate.SetLunD(FlunarDate);
    SetWeek;
    SetFeast;
    Change(Self);
  end;
end;

procedure TTransDate.SetISO8601(const Value: Boolean);
begin
  FISO8601 := Value;
  SetWeek;
end;

procedure TTransDate.SetLeapMonth(const Value: Boolean);
begin
  FLeapMonth := Value;
  if (GetLeapMonth(FLunarDate.lYear) = FLunarDate.lMonth) then
    if FLeapMonth <> FLunarDate.FlagLeapMonth then
    begin
      LunarDate.FlagLeapMonth := Value;
      Date := LunarDateToDate(FLunarDate);
    end;
end;

procedure TTransDate.SetWeek;
begin
  if FISO8601 then
    FWeek := DayOfTheWeek(FDate)
  else
    FWeek := DayOfWeek(FDate);
end;

procedure TTransDate.Change(Sender: TObject);
begin
  if Assigned(FOnChange) then
    FOnChange(Self);
end;

procedure TTransDate.FLunarDateChange(LD: TLunarDate);
begin
  inherited;
  FDate := LunarDateToDate(LD);
  SetWeek;
  SetFeast;
  Change(Self);
end;

procedure TTransDate.SetBookOfChanges(const Value: Boolean);
begin
  FBookOfChanges := Value;
  FLunarDate.BookOfChanges := Value;
end;

end.