datecn.pas

一款不错的年历控件

    inc(iTotalDays,DaysPerMonth(iYear,iMonth));
    inc(iMonth);
    if iMonth > 12 then
    begin
      inc(iYear);
      iMonth := 1;
    end;
  end;

  Result := iTotalDays;

end;



//日期是该年的第几天，1月1日为第一天

function DaysNumberOfDate(ADate: TDate): Integer;
var
  DaysNumber: Integer;
  I: Integer;
  iYear, iMonth, iDay: Word;
begin
  DecodeDate(ADate, iYear, iMonth, iDay);
  DaysNumber := 0;
  for I := 1 to iMonth - 1 do
    Inc(DaysNumber, MonthDays[IsLeapYear(iYear), I]);
  Inc(DaysNumber, iDay);
  Result := DaysNumber;
end;

//日期的农历日期，返回农历格式：月份*100 + 日，负数为闰月
//超出范围则返回0

function CnDateOfDate(ADate: TDate): Integer;
var
  CnMonth, CnMonthDays: array[0..15] of Integer;
  CnBeginDay, LeapMonth: Integer;
  iYear, iMonth, iDay: Word;
  Bytes: array[0..3] of Byte;
  I: Integer;
  CnMonthData: Word;
  DaysCount, CnDaysCount, ResultMonth, ResultDay: Integer;
begin
  DecodeDate(ADate, iYear, iMonth, iDay);
  if (iYear < START_YEAR) or (iYear > END_YEAR) then
  begin
    Result := 0;
    Exit;
  end;
  Bytes[0] := CnData[(iYear - START_YEAR) * 4];
  Bytes[1] := CnData[(iYear - START_YEAR) * 4 + 1];
  Bytes[2] := CnData[(iYear - START_YEAR) * 4 + 2];
  Bytes[3] := CnData[(iYear - START_YEAR) * 4 + 3];
  if (Bytes[0] and $80) <> 0 then
    CnMonth[0] := 12
  else
    CnMonth[0] := 11;
  CnBeginDay := (Bytes[0] and $7F);
  CnMonthData := Bytes[1];
  CnMonthData := CnMonthData shl 8;
  CnMonthData := CnMonthData or Bytes[2];
  LeapMonth := Bytes[3];

  for I := 15 downto 0 do
  begin
    CnMonthDays[15 - I] := 29;
    if ((1 shl I) and CnMonthData) <> 0 then
      Inc(CnMonthDays[15 - I]);
    if CnMonth[15 - I] = LeapMonth then
      CnMonth[15 - I + 1] := -LeapMonth
    else
    begin
      if CnMonth[15 - I] < 0 then //上月为闰月
        CnMonth[15 - I + 1] := -CnMonth[15 - I] + 1
      else
        CnMonth[15 - I + 1] := CnMonth[15 - I] + 1;
      if CnMonth[15 - I + 1] > 12 then CnMonth[15 - I + 1] := 1;
    end;
  end;

  DaysCount := DaysNumberOfDate(ADate) - 1;
  if DaysCount <= (CnMonthDays[0] - CnBeginDay) then
  begin
    if (iYear > START_YEAR) and
      (CnDateOfDate(EncodeDate(iYear - 1, 12, 31)) < 0) then
      ResultMonth := -CnMonth[0]
    else
      ResultMonth := CnMonth[0];
    ResultDay := CnBeginDay + DaysCount;
  end
  else
  begin
    CnDaysCount := CnMonthDays[0] - CnBeginDay;
    I := 1;
    while (CnDaysCount < DaysCount) and
      (CnDaysCount + CnMonthDays[I] < DaysCount) do
    begin
      Inc(CnDaysCount, CnMonthDays[I]);
      Inc(I);
    end;
    ResultMonth := CnMonth[I];
    ResultDay := DaysCount - CnDaysCount;
  end;
  if ResultMonth > 0 then
    Result := ResultMonth * 100 + ResultDay
  else
    Result := ResultMonth * 100 - ResultDay;
end;

function CnYearOfDate(ADate : TDate):Integer;
var
  iYear,iMonth,iDay : Word;
begin
  DecodeDate(ADate, iYear, iMonth, iDay);

  if iMonth -  Abs(CnMonthOfDate(ADate)) < 0 then dec(iYear);

  Result := iYear;
end;

function CnMonthOfDate(ADate: TDate): Integer;
begin
  Result := CnDateOfDate(ADate) div 100;
end;

function CnDayOfDate(ADate: TDate): Integer;
begin
  Result := Abs(CnDateOfDate(ADate)) mod 100;
end;

function CnMonthOfDateCH(ADate: TDate): string;
const
  CnMonthStr: array[1..12] of string = (
    '正', '二', '三', '四', '五', '六', '七', '八', '九', '十',
    '冬', '腊');
var
  iMonth: Integer;
begin
  iMonth := CnMonthOfDate(ADate);
  if iMonth < 0 then
    Result := '闰' + CnMonthStr[-iMonth]
  else
    Result := CnMonthStr[iMonth] + '月';
end;

function CnDayOfDateCH(ADate: TDate): string;
var
  iDay: Integer;
begin
  iDay := CnDayOfDate(ADate);
  Result := CnDayStr[iDay];
end;

function GetLunarHolDay(ADate: TDate): string;
var
  iDay,iMonth: Integer;
begin
  iDay := CnDayOfDate(ADate);
  iMonth := CnMonthOfDate(ADate);

  if (CnMonthOfDate(ADate + 1) = 1) and (CnDayOfDate(ADate + 1) =1) then
  begin
    Result := '除夕';
    Exit;
  end;

  case iMonth of
    1: case iDay of
         1:Result := '春节';
         15:Result := '元宵节';
         else Result := '';
       end;
    5: if iDay = 5 then
         Result := '端午节'
       else
         Result := '';
    7: if iDay = 7 then
         Result := '七夕节'
       else
         Result := '';
    8: if iDay = 15 then
          Result := '中秋节'
       else
          Result := '';
    9: if iDay = 9 then
         Result := '重阳节'
       else
         Result := '';
    12: if iDay = 8 then
         Result := '腊八节'
       else
         Result := '';
    else
        Result := '';
  end; {case}
end;

function GetSolarTerm(ADate:TDateTime):string;
var
 i,iYear,iMonth,iDay:Word;

  function l_GetSolarTerm(iYear,iMonth,iDay:Word):Word;
  var
    Flag:Byte;
    Day:Word;
  begin
    Flag:=solarTerm[(iYear-START_YEAR)*12+iMonth-1];
    if iDay<15 then
      Day:=15-((Flag shr 4) and $0f)
    else
      Day:=(Flag and $0f)+15;
    if iDay=Day then
      if iDay>15 then
        Result:=(iMonth-1)*2+2
      else
        Result:=(iMonth-1)*2+1
    else
    Result:= 0;
  end;

begin
 DecodeDate(ADate,iYear,iMonth,iDay);
 i:=l_GetSolarTerm(iYear,iMonth,iDay);

 if (i in [1..24]) then
   Result := SolarTermStr[i]
 else
   Result := '';
end;

function GetSunHolDay(ADate:TDate):string;
begin
  //
end;

function GetAnimals(AYear : Integer):string;
begin
  Result := AnimalsStr[(AYear - 4) mod 12 + 1];
end;

function GetCyclical(ADate :TDateTime;ACyclical : TCyclical):String;
var
  cCyclical : String;
  iMonth,iYear,iDay ,iHour,iMin,iSec,iMSec: Word;
  iTmp : integer;

  function Gan(ANum:Integer):String;
  var
    iG : Word;
  begin
    iG := ANum mod 10;
    if iG = 0 then iG := 10;

    Result := GanStr[iG];
  end;

  function Zhi(ANum:Integer):String;
  var
    iZ : Word;
  begin
    iZ := ANum mod 12;
    if iZ = 0 then iZ := 12;
    Result := ZhiStr[iZ];
  end;

  function Cyclical(ANum:Integer):String;
  begin
    Result := Gan(ANum) + Zhi(ANum);
  end;

  function LanarHour(AHour: Word):Integer;
  begin
    Case AHour of
       23,0: Result := 1;
        1,2: Result := 2;
        3,4: Result := 3;
        5,6: Result := 4;
        7,8: Result := 5;
       9,10: Result := 6;
      11,12: Result := 7;
      13,14: Result := 8;
      15,16: Result := 9;
      17,18: Result := 10;
      19,20: Result := 11;
      21,22: Result := 12;
      else  Result := 0;
    end;//case
  end;

  function LanarHourCh(AHour: Word):String;
  begin
    if LanarHour(AHour) > 0 then
      Result := HourStr[LanarHour(AHour)]
    else  Result := '';
  end;

begin
  DecodeDate(ADate,iYear,iMonth,iDay);
  DecodeTime(ADate,iHour,iMin,iSec,iMSec);
  Case ACyclical of
  wqYear: begin
               //年柱 1900年春分后为庚子年(60进制36)
               cCyclical := Cyclical(CnYearOfDate(ADate) - 1900 + 36 + 1);
          end;
  wqMonth: begin
               //月柱 1900年1月小寒以前为 丙子月(60进制12)
               case iMonth - Abs(CnMonthOfDate(ADate)) of
                 0: cCyclical := Cyclical((CnYearOfDate(ADate) -1900)*12 + iMonth + 13 + 1);
                 1: cCyclical := Cyclical((CnYearOfDate(ADate) -1900)*12 + iMonth + 13);
                 2: cCyclical := Cyclical((CnYearOfDate(ADate) -1900)*12 + iMonth + 13 - 1);
          -11,-10: begin
                      case iMonth of
                        1: cCyclical := Cyclical((iYear -1900)*12 + iMonth + 13);
                        2: cCyclical := Cyclical((iYear -1900)*12 + iMonth + 13 - 1);
                      end;//case
                    end;
               end;//case
           end;
  wqDay:  begin
            //1900/1/1 日柱为甲戌日(60进制10)
            //与 1900/1/1 相差天数的日柱
            cCyclical := Cyclical(DaysOnRange(1900,1,iYear,iMonth) +10 + iDay);
          end;

  wqHour: begin  //时柱
            if iHour = 23 then begin
              iTmp := ((DaysOnRange(1900,1,iYear,iMonth) + iDay + 1 ) mod 10 ) * 2 + LanarHour(iHour) - 2;
              if iTmp > 10 then dec(iTmp,10);
              if iTmp = 0 then iTmp := 10;
              if iTmp < 0 then inc(iTmp,10);
              cCyclical := GanStr[iTmp] + LanarHourCh(iHour);
            end
            else begin
              iTmp := ((DaysOnRange(1900,1,iYear,iMonth) + iDay ) mod 10) * 2 + LanarHour(iHour) - 2 ;
              if iTmp > 10 then dec(iTmp,10);
              if iTmp = 0 then iTmp := 10;
              if iTmp < 0 then inc(iTmp,10);
              cCyclical := GanStr[iTmp] + LanarHourCh(iHour);
            end;
          end;
  end; //case
  Result := cCyclical;
end;

end.