datecn.pas

一个很漂亮的农历控件

  If Animal = '戌狗' Then
    result := 10;

  If Animal = '亥猪' Then
    result := 11;


End;

Function CnDateOfDate(Date: TDate): Integer;
Var
  CnMonth, CnMonthDays: Array[0..15] Of Integer;
  CnBeginDay, LeapMonth: Integer;
  yyyy, mm, dd: Word;
  Bytes: Array[0..3] Of Byte;
  I: Integer;
  CnMonthData: Word;
  DaysCount, CnDaysCount, ResultMonth, ResultDay: Integer;
Begin
  //  Date := StrToDate(FormatDateTime('yyyy/mm/dd', Date));
  DecodeDate(Date, yyyy, mm, dd);
  If (yyyy < 1901) Or (yyyy > 2050) Then
    Begin
      Result := 0;
      Exit;
    End;
  Bytes[0] := CnData[(yyyy - 1901) * 4];
  Bytes[1] := CnData[(yyyy - 1901) * 4 + 1];
  Bytes[2] := CnData[(yyyy - 1901) * 4 + 2];
  Bytes[3] := CnData[(yyyy - 1901) * 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(Date) - 1;
  If DaysCount <= (CnMonthDays[0] - CnBeginDay) Then
    Begin
      If (yyyy > 1901) And
        (CnDateOfDate(EncodeDate(yyyy - 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 CnMonth(Date: TDate): Integer;
Begin
  Result := Abs(CnDateOfDate(Date) Div 100);
End;

Function CnMonthOfDate(Date: TDate; Days: Integer): String;
Var
  Year, Month, Day: word;
Begin
  DecodeDate(Date, Year, Month, Day);
  Result := CnMonthOfDate(EncodeDate(Year, Month, Days));

End;

Function CnMonthOfDate(Date: TDate): String;
Const
  CnMonthStr: Array[1..12] Of String = (
    '正', '二', '三', '四', '五', '六', '七', '八', '九', '十',
    '冬', '腊');
Var
  Month: Integer;
Begin
  //  Date := StrToDate(FormatDateTime('yyyy/mm/dd', Date));
  Month := CnDateOfDate(Date) Div 100;
  If Month < 0 Then
    Result := '闰' + CnMonthStr[-Month]
  Else
    Result := CnMonthStr[Month] + '月';
End;

Function CnDayOfDatePH(Date: TDate): String;
Const
  CnDayStr: Array[1..30] Of String = (
    '初一', '初二', '初三', '初四', '初五',
    '初六', '初七', '初八', '初九', '初十',
    '十一', '十二', '十三', '十四', '十五',
    '十六', '十七', '十八', '十九', '二十',
    '廿一', '廿二', '廿三', '廿四', '廿五',
    '廿六', '廿七', '廿八', '廿九', '三十');
Var
  Day: Integer;
Begin
  //  Date := StrToDate(FormatDateTime('yyyy/mm/dd', Date));
  Day := Abs(CnDateOfDate(Date)) Mod 100;
  Result := CnDayStr[Day];
End;

Function CnDateOfDateStr(Date: TDate): String;
Begin
  Result := CnMonthOfDate(Date) + CnDayOfDatePH(Date);
End;

Function CnDayOfDate(Date: TDate; Days: integer; ShowDate: Boolean = false): String; //指定日期的农历日包括节日
Var
  Year, Month, Day: word;
Begin
  DecodeDate(Date, Year, Month, Day);
  Result := CnDayOfDate(EncodeDate(Year, Month, Days));

End;

Function CnDayOfDate(Year,Month,Day: integer): String; overload; //指定日期的农历日包括节日
Begin
  Result := CnDayOfDate(EncodeDate(Year, Month, Day));
End;


Function CnDay(Date: TDate): Integer;
Begin
  Result := Abs(CnDateOfDate(Date)) Mod 100;
End;

Function CnDayOfDate(Date: TDate): String;
Const
  CnDayStr: Array[1..30] Of String = (
    '初一', '初二', '初三', '初四', '初五',
    '初六', '初七', '初八', '初九', '初十',
    '十一', '十二', '十三', '十四', '十五',
    '十六', '十七', '十八', '十九', '二十',
    '廿一', '廿二', '廿三', '廿四', '廿五',
    '廿六', '廿七', '廿八', '廿九', '三十');
Var
  Day: Integer;
Begin
  //  Date := StrToDate(FormatDateTime('yyyy/mm/dd', Date));
  Day := Abs(CnDateOfDate(Date)) Mod 100;
  Result := CnDayStr[Day];

End;

Function CnDateOfDateStrPH(Date: TDate): String;
Begin
  Result := CnMonthOfDate(Date) + CnDayOfDate(Date);
End;

Function CnDayOfDateJr(Date: TDate; Days: Integer): String;
Var
  Year, Month, Day: word;
Begin
  DecodeDate(Date, Year, Month, Day);
  Result := CnDayOfDateJr(EncodeDate(Year, Month, Days));

End;

Function CnDayOfDateJr(Date: TDate): String;
Var
  Day: Integer;
Begin
  Result := '';
  Day := Abs(CnDateOfDate(Date)) Mod 100;
  Case Day Of
    1:
      If (CnMonthOfDate(Date) = '正月') Then
        Result := '春节';
    5:
      If CnMonthOfDate(Date) = '五月' Then
        Result := '端午节';
    7:
      If CnMonthOfDate(Date) = '七月' Then
        Result := '七夕节';
    15:
      If CnMonthOfDate(Date) = '八月' Then
        Result := '中秋节'
      Else
        If (CnMonthOfDate(Date) = '正月') Then
          Result := '元宵节';
    9:
      If CnMonthOfDate(Date) = '九月' Then
        Result := '重阳节';
    8:
      If CnMonthOfDate(Date) = '腊月' Then
        Result := '腊八节';
  Else
    If (CnMonthOfDate(Date + 1) = '正月') And (CnMonthOfDate(Date) <> '正月') Then
      Result := '除夕';
  End; {case}
End;

Function CnanimalOfYear(Date: TDate): String; //返回十二生肖
Var
  i: integer;
  DateStr: String;
Begin
  DateStr := FormatDateTime('yyyy/mm/dd', Date);
  i := length(inttostr(month(date)));
  Case (StrToInt(Copy(DateStr, 1, 4)) - StrToInt(BaseAnimalDate))
    Mod 12 Of
    0:
      If (StrToInt(Copy(DateStr, 6, i)) < 4) And ((Pos('腊',
        CnMonthOfDate(Date)) = 0) And (Pos('冬', CnMonthOfDate(Date)) = 0)) Then
        Result := '子鼠'
      Else
        Begin
          If StrToInt(Copy(DateStr, 6, i)) < 4 Then
            Result := '亥猪'
          Else
            Result := '子鼠';
        End;
    1, -11:
      If (StrToInt(Copy(DateStr, 6, i)) < 4) And ((Pos('腊',
        CnMonthOfDate(Date)) = 0) And (Pos('冬', CnMonthOfDate(Date)) = 0)) Then
        Result := '丑牛'
      Else
        Begin
          If StrToInt(Copy(DateStr, 6, i)) < 4 Then
            Result := '子鼠'
          Else
            Result := '丑牛';
        End;
    2, -10:
      If (StrToInt(Copy(DateStr, 6, i)) < 4) And ((Pos('腊',
        CnMonthOfDate(Date)) = 0) And (Pos('冬', CnMonthOfDate(Date)) = 0)) Then
        Result := '寅虎'
      Else
        Begin
          If StrToInt(Copy(DateStr, 6, i)) < 4 Then
            Result := '丑牛'
          Else
            Result := '寅虎';
        End;
    3, -9:
      If (StrToInt(Copy(DateStr, 6, i)) < 4) And ((Pos('腊',
        CnMonthOfDate(Date)) = 0) And (Pos('冬', CnMonthOfDate(Date)) = 0)) Then
        Result := '卯兔'
      Else
        Begin
          If StrToInt(Copy(DateStr, 6, i)) < 4 Then
            Result := '寅虎'
          Else
            Result := '卯兔';
        End;
    4, -8:
      If (StrToInt(Copy(DateStr, 6, i)) < 4) And ((Pos('腊',
        CnMonthOfDate(Date)) = 0) And (Pos('冬', CnMonthOfDate(Date)) = 0)) Then
        Result := '辰龙'
      Else
        Begin
          If StrToInt(Copy(DateStr, 6, i)) < 4 Then
            Result := '卯兔'
          Else
            Result := '辰龙';
        End;
    5, -7:
      If (StrToInt(Copy(DateStr, 6, i)) < 4) And ((Pos('腊',
        CnMonthOfDate(Date)) = 0) And (Pos('冬', CnMonthOfDate(Date)) = 0)) Then
        Result := '巳蛇'
      Else
        Begin
          If StrToInt(Copy(DateStr, 6, i)) < 4 Then
            Result := '辰龙'
          Else
            Result := '巳蛇';
        End;
    6, -6:
      If (StrToInt(Copy(DateStr, 6, i)) < 4) And ((Pos('腊',
        CnMonthOfDate(Date)) = 0) And (Pos('冬', CnMonthOfDate(Date)) = 0)) Then
        Result := '午马'
      Else
        Begin
          If StrToInt(Copy(DateStr, 6, i)) < 4 Then
            Result := '巳蛇'
          Else
            Result := '午马';
        End;
    7, -5:
      If (StrToInt(Copy(DateStr, 6, i)) < 4) And ((Pos('腊',
        CnMonthOfDate(Date)) = 0) And (Pos('冬', CnMonthOfDate(Date)) = 0)) Then
        Result := '未羊'
      Else
        Begin
          If StrToInt(Copy(DateStr, 6, i)) < 4 Then
            Result := '午马'
          Else
            Result := '未羊';
        End;
    8, -4:
      If (StrToInt(Copy(DateStr, 6, i)) < 4) And ((Pos('腊',
        CnMonthOfDate(Date)) = 0) And (Pos('冬', CnMonthOfDate(Date)) = 0)) Then
        Result := '申猴'
      Else
        Begin
          If StrToInt(Copy(DateStr, 6, i)) < 4 Then
            Result := '未羊'
          Else
            Result := '申猴';
        End;
    9, -3:
      If (StrToInt(Copy(DateStr, 6, i)) < 4) And ((Pos('腊',
        CnMonthOfDate(Date)) = 0) And (Pos('冬', CnMonthOfDate(Date)) = 0)) Then
        Result := '酉鸡'
      Else
        Begin
          If StrToInt(Copy(DateStr, 6, i)) < 4 Then
            Result := '申猴'
          Else
            Result := '酉鸡';
        End;
    10, -2:
      If (StrToInt(Copy(DateStr, 6, i)) < 4) And ((Pos('腊',
        CnMonthOfDate(Date)) = 0) And (Pos('冬', CnMonthOfDate(Date)) = 0)) Then
        Result := '戌狗'
      Else
        Begin
          If StrToInt(Copy(DateStr, 6, i)) < 4 Then
            Result := '酉鸡'
          Else
            Result := '戌狗';
        End;
    11, -1:
      If (StrToInt(Copy(DateStr, 6, i)) < 4) And ((Pos('腊',
        CnMonthOfDate(Date)) = 0) And (Pos('冬', CnMonthOfDate(Date)) = 0)) Then
        Result := '亥猪'
      Else
        Begin
          If StrToInt(Copy(DateStr, 6, i)) < 4 Then
            Result := '戌狗'
          Else
            Result := '亥猪';
        End;
  End; {case}
End;

Function CnSkyStemOfYear(Date: TDate): String; //返回十大天干