transdate.pas

公历与农历转换组件

{ Copyright (c) 2004 by Delphi 7 - Lu XiaoGuang V1.0 }

unit TransDate;

interface

uses
  Windows, SysUtils, Classes, Controls, DateUtils;

const
  StartYear: Integer = 1900;
  EndYear: Integer = 2056;

type

  _Lunar_DateSeparator = record
    sYear: string[2];
    sMonth: string[2];
    sDay: string[2];
    sLeapMonth: string[2];
  end;
  TLunar_DateSeparator = _Lunar_DateSeparator;

type
  TLunarDate = class;

  TChangeLunarDateEvent = procedure(LD: TLunarDate) of object;

  TLunarDate = class(TPersistent)
  private
    FFLagLeapMonth: Boolean;
    FcYear: ShortString;
    FlDay: Integer;
    FlYear: Integer;
    FlMonth: Integer;
    FcMonth: ShortString;
    FcDay: ShortString;
    FSolarTerm: ShortString;
    FAnimlYear: ShortString;
    FMaxMonthDays: integer;
    FOnchange: TChangeLunarDateEvent;
    FFeastOfLunar: string;
    FBookOfChanges: Boolean;
    procedure SetlDay(const Value: Integer);
    procedure SetlMonth(const Value: Integer);
    procedure SetlYear(const Value: Integer);
    procedure SetFFlagLeapMonth(const Value: Boolean);
    procedure SetHeavenlyStemsEarthlyBranches(var LD: TlunarDate);
    procedure SetFeastOfLunar(var LD: TLunardate);
    procedure Change; virtual;
    procedure SetBookOfChanges(const Value: Boolean);
    procedure SetLunD(var LD: TLunarDate);
    property BookOfChanges: Boolean read FBookOfChanges write SetBookOfChanges;
  public
    constructor Create(AOwner: TComponent); virtual;
    destructor Destroy; override;
    function GetMonthDays(LY, LM: Integer): integer;
  published
    property MaxMonthDays: integer read FMaxMonthDays write FMaxMonthDays;
    property lYear: Integer read FlYear write SetlYear;
    property lMonth: Integer read FlMonth write SetlMonth;
    property lDay: Integer read FlDay write SetlDay;
    property cYear: Shortstring read FcYear;
    property cMonth: Shortstring read FcMonth;
    property cDay: Shortstring read FcDay;
    property FlagLeapMonth: Boolean read FFlagLeapMonth write SetFFlagLeapMonth;
    property AnimalYear: Shortstring read FAnimlYear;
    property SolarTerm: Shortstring read FSolarTerm;
    property FeastOfLunar: string read FFeastOfLunar;
    property OnChange: TChangeLunarDateEvent read FOnchange write FOnchange;
  end;

  TTransDate = class(TComponent)
  private
    FDate: TDate;
    FLeapMonth: Boolean;
    FISO8601: Boolean;
    FWeek: Integer;
    FOnChange: TNotifyEvent;
    FLunarDate: TLunarDate;
    FMaxMonthDays: integer;
    FLunar_DateSeparator: TLunar_DateSeparator;
    FFeast: string;
    FBookOfChanges: Boolean;
    function GetConstellation: string;
    function GetDate: TDate;
    function GetLunarDate: TLunarDate;
    function GetLunar_DateSeparator: TLunar_DateSeparator;
    procedure SetDate(Value: TDate);
    procedure SetLunar_DateSeparator(Value: TLunar_DateSeparator);
    procedure SetISO8601(const Value: Boolean);
    procedure SetLeapMonth(const Value: Boolean);
    procedure SetWeek;
    procedure SetFeast;
    procedure SetLunarDate(const Value: TLunarDate);
    procedure Change(Sender: TObject); virtual;
    procedure FLunarDateChange(LD: TLunarDate); virtual;
    procedure SetBookOfChanges(const Value: Boolean);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure DateToLunarDate(sDate: TDate; var LD: TLunarDate);
    function LunarDateToDate(iDate: TLunarDate): TDate;
    function LunarDateToStr: string;
    procedure StrToLunarDate(DateStr: string; var LD: TLunarDate);
    property LunarDateSeparator: TLunar_DateSeparator read GetLunar_DateSeparator write SetLunar_DateSeparator;
  published
    property BookOfChanges: Boolean read FBookOfChanges write SetBookOfChanges;
    property MaxMonthDays: integer read FMaxMonthDays write FMaxMonthDays;
    property LunarDate: TLunarDate read GetLunarDate write SetLunarDate;
    property Constellation: string read GetConstellation;
    property ISO8601: Boolean read FISO8601 write SetISO8601;
    property Week: Integer read FWeek;
    property Date: TDate read GetDate write SetDate;
    property Feast: string read FFeast;
    property LeapMonth: Boolean read FLeapMonth write SetLeapMonth;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
  end;

procedure Register;

function GetLeapMonth(iYear: Integer): Integer;

implementation

uses TransDateConst;

{ TODO : Get Solar Term }

function GetSolarTermD(sDate: TDate): Integer;
var
  Y, M, D: Word;
  T: Byte;
  Day: Integer;
begin
  Result := -1;
  DecodeDate(sDate, Y, M, D);
  if (Y >= StartYear) and (Y <= EndYear) then
  begin
    T := SolarTermDay[(Y - StartYear) * 12 + M - 1];
    if D < 15 then
      Day := 15 - (T shr 4)
    else
      Day := (T and $0F) + 15;
    if D = Day then
    begin
      if D > 15 then
        Result := (M - 1) * 2 + 1
      else
        Result := (M - 1) * 2;
    end;
  end;
end;

{ TODO : Search The LunarMonth table Get the Number for Month in Year }

function GetLeapMonth(iYear: Integer): Integer;
var
  D: Byte;
begin
  Result := 0;
  if (iYear >= StartYear) and (iYear <= EndYear) then
  begin
    D := LunarMonth[(iYear - StartYear) div 2];
    if ((iYear - StartYear) mod 2) = 0 then
    begin
      Result := D shr 4;
    end
    else
    begin
      Result := D and $0F
    end;
  end;
end;

{ TODO : Get Lunar Month's Days }

function LunarMonthDays(iYear, iMonth: WORD): Integer;
var
  H, L: Integer;
  Bit: Integer;
begin
  if (iYear >= StartYear) and (iYear <= EndYear) then
  begin
    H := 0;
    L := 29;
    Bit := 16 - iMonth;
    if ((iMonth > GetLeapMonth(iYear)) and (GetLeapMonth(iYear) > 0)) then
      DEC(Bit);
    if (LunarMonthDay[iYear - StartYear] and (1 shl Bit)) > 0 then
      INC(L);
    if iMonth = GetLeapMonth(iYear) then
      if (LunarMonthDay[iYear - StartYear] and (1 shl (Bit - 1))) > 0 then
        H := 30
      else
        H := 29;
    H := H shl 16;
    Result := H or L;
  end
  else
    Result := 30;
end;

{ TODO : Get The Lunar Year's Days }

function LunarYearDays(iYear: Integer): Integer;
var
  Days: Integer;
  I: Integer;
begin
  Result := 0;
  if (iYear >= StartYear) and (iYear <= EndYear) then
  begin
    Days := 0;
    for I := 1 to 12 do
    begin
      Days := Days + (((LunarMonthDays(iYear, I)) shr 16) and $FFFF);
      Days := Days + ((LunarMonthDays(iYear, I)) and $FFFF);
    end;
    Result := Days;
  end;
end;

{ TLunarDate }
//-------------------------------------------------------------

constructor TLunarDate.Create(AOwner: TComponent);
var
  Y, M, D: Word;
begin
  inherited Create;
  DecodeDate(Date, Y, M, D);
  FlYear := Y;
  FlMonth := M;
  FlDay := D;
  FMaxMonthDays := GetMonthDays(FlYear, FlMonth);
end;

destructor TLunarDate.Destroy;
begin
  inherited;
end;

function TLunarDate.GetMonthDays(LY, LM: integer): integer;
begin
  if ((((LunarMonthDays(LY, LM)) shr 16) and $FFFF) <> 0) and FFLagLeapMonth then
    Result := (((LunarMonthDays(LY, LM)) shr 16) and $FFFF)
  else
    Result := (LunarMonthDays(LY, LM)) and $FFFF;
end;

{ TODO : SetHeavenlyStemsEarthlyBranchs }

procedure TLunarDate.SetHeavenlyStemsEarthlyBranches(var LD: TLunarDate);
var
  Y, M, D: Word;
  sDate: Integer;
  M1: Integer;

  function CalLunarM(Y, M: Word): Word;
  var
    T: Word;
  begin
    T := SolarTermDay[(Y - StartYear) * 12 + M - 1];
    Result := 15 - (T shr 4);
  end;

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

begin
  with LD do
  begin
    Y := FlYear;
    M := FlMonth;
    D := FlDay;
    if (M = GetLeapMonth(Y)) and FFlagLeapMonth then
    begin
      D := D + LunarMonthDays(Y, M) and $FFFF;
    end;
    if DelMonth then
      while (Y >= StartYear) and (M >= 1) do
      begin
        D := D + (LunarMonthDays(Y, M) shr 16) and $FFFF;
        D := D + LunarMonthDays(Y, M) and $FFFF;
        if not DelMonth then
          Break;
      end;
    if (FlYear > (StartYear - 1)) then
    begin
      sDate := D + LunarDelta;
      D := sDate - DateDelta;
    end
    else
      SDate := D + DateDelta;

    FcDay := HeavenlyStemsStr[((D + StartDayHeavenly) mod 10)];
    FcDay := FcDay + EarthlyBranchesStr[((D + StartDayEarthly) mod 12)];

    if FBookOfChanges then
    begin
      DecodeDate(sDate, Y, M, D);
      if (sDate >= EncodeDate(Y, 1, CalLunarM(Y, 1))) and (M > 1) then
      begin
        M1 := 0;
        repeat
          inc(M1);
          if M1 >= 12 then
          begin
            M1 := 1;
            inc(Y);
          end;
        until EncodeDate(Y, M1 + 1, CalLunarM(Y, M1 + 1)) > sDate;
        if M1 = 1 then
        begin
          M1 := 12;
          dec(y);
        end;
      end
      else
      begin
        if D >= CalLunarM(Y, M) then
        begin
          M1 := 1;
        end
        else
        begin
          M1 := 12;
          dec(y);
        end;
      end;
      FcMonth := HeavenlyStemsStr[(((Y - StartYear + 1) * 12 + M1 + StartMonthHeavenly - 1) mod 10)];
      FcMonth := FcMonth + EarthlyBranchesStr[(((Y - StartYear + 1) * 12 + M1 + StartMonthEarthly - 1) mod 12)];
    end
    else
    begin
      FcMonth := HeavenlyStemsStr[(((FlYear - StartYear + 1) * 12 + FlMonth + StartMonthHeavenly) mod 10)];
      FcMonth := FcMonth + EarthlyBranchesStr[(((FlYear - StartYear + 1) * 12 + FlMonth + StartMonthEarthly) mod 12)];
    end;

    if FBookOfChanges then
    begin
      DecodeDate(sDate, Y, M, D);
      if sDate >= EncodeDate(Y, 2, CalLunarM(Y, 2)) then
        M1 := 0
      else
        M1 := 1;
      FcYear := HeavenlyStemsStr[((Y - M1 + StartYearHeavenly) mod 10)];
      FcYear := FcYear + EarthlyBranchesStr[((Y - M1 + StartYearEarthly) mod 12)];
      FAnimlYear := TwelveAnimalsStr[((Y - M1 + StartYearEarthly) mod 12)];
    end
    else
    begin
      FcYear := HeavenlyStemsStr[((FlYear + StartYearHeavenly) mod 10)];
      FcYear := FcYear + EarthlyBranchesStr[((FlYear + StartYearEarthly) mod 12)];
      FAnimlYear := TwelveAnimalsStr[((FlYear + StartYearEarthly) mod 12)];
    end;

    if GetSolarTermD(sDate) < 0 then
      FSolarTerm := ''
    else
      FSolarTerm := SolarTermStr[GetSolarTermD(sDate)];
  end;
end;

procedure TLunarDate.SetlYear(const Value: Integer);
begin
  if (Value <> FlYear) and ((Value >= StartYear) and (Value <= EndYear)) then
  begin
    FlYear := Value;
    SetLunD(Self);
    Change;
  end;
end;

procedure TLunarDate.SetlMonth(const Value: Integer);
begin
  if (Value <> FlMonth) and (((Value >= 1) and (Value <= 12))) then
  begin
    FlMonth := Value;
    SetLunD(Self);
    Change;
  end;
end;

procedure TLunarDate.SetlDay(const Value: Integer);
begin
  if ((Value >= 1) and (Value <= GetMonthDays(FlYear, FlMonth))) then
    FlDay := Value;
  SetLunD(Self);
  Change;
end;

procedure TLunarDate.SetFeastOfLunar(var LD: TLunarDate);
var
  I: Integer;
  Y: Word;
begin
  with LD do
  begin
    FFeastOfLunar := '';
    Y := (Word(FlMonth) shl 8) or Word(FlDay);
    for I := Low(FeastOfLunars) to High(FeastOfLunars) do
      if FeastOfLunars[I].M = Y then
      begin
        FFeastOfLunar := FeastOfLunars[I].N;
        Break;
      end;
    if (FlMonth = 12) and (FlDay = FMaxMonthDays) then
      FFeastOfLunar := '除夕';
    if FSolarTerm = '清明' then
      FFeastOfLunar := '清明节';
  end;
end;

procedure TLunarDate.SetLunD(var LD: TLunarDate);
begin
  with LD do
  begin
    FMaxMonthDays := GetMonthDays(FlYear, FlMonth);
    if FlDay > FMaxMonthDays then
    begin
      FlDay := FMaxMonthDays;
    end;
  end;
  SetHeavenlyStemsEarthlyBranches(LD);
  SetFeastOfLunar(LD);
end;

procedure TLunarDate.SetFFlagLeapMonth(const Value: Boolean);
begin
  if FFLagLeapMonth <> Value then
  begin
    FFlagLeapMonth := Value;
    Change;
  end;
end;

procedure TLunarDate.SetBookOfChanges(const Value: Boolean);
begin
  FBookOfChanges := Value;
  SetHeavenlyStemsEarthlyBranches(Self);
  Change;
end;

procedure TLunarDate.Change;
begin
  if Assigned(FOnChange) then
    FOnChange(Self);
end;

procedure Register;
begin
  RegisterComponents('LXG', [TTransDate]);
end;

{ TODO : initialize Date & LunarDate }