lsscalendar.pas

是一个免费并开源的支持农历的月历控件

  sy, sm, sd: Word;
begin
  DecodeDate(TheDate, sy, sm, sd);
  if sy < 1900 then exit;
  term:= sTerm(sy, (sm - 1) * 2);  // 当月的节气日期

  //年柱 1900年立春后为庚子年(60进制36)
  Result.Year:= sy - 1900 + 36;
  //依立春日期调整年柱.立春日固定在公历2月
  if (sm = 1) or ((sm = 2) and (TheDate < Term)) then
    Result.Year:= sy - 1900 + 35;

  //月柱 农历1900年1月小寒以前为 丙子月(60进制12)
  Result.Month:= (sy - 1900) * 12 + sm + 11;
  //依节气调整月柱
  if TheDate >= DateOf(term) then Result.Month:= (sy - 1900) * 12 + sm + 12;

  // 1900/1/1 日柱为甲辰日(60进制10)
  Result.Day:= DaysBetween(EncodeDate(1900,1,1),TheDate) + 10;
end;

// 算出公历, 传入农历日期控件, 返回公历
function TLssCalendar.ToGreg(objDate: THzDate): TDate;
var
  i, j, t, leap, temp, offset: integer;
  isLeap: Boolean;
  y, m: integer;
begin

  Result:= EncodeDate(1,1,1);
  if not ChkHzDate(objDate) then exit;

  isLeap:= False;
  y:= objDate.Year;
  m:= objDate.Month;
  leap:= leapMonth(y);

  //本年内从大年初一过来的天数
  offset:= 0;
  i:= 1;
  while i < m do
  begin
    if i = leap then
    begin
      if isLeap then
      begin
        temp:= DaysOfleapMonth(y);
        isLeap:= False;
      end
      else begin
        temp:= daysOfmonth(y, i);
        isLeap:= True;
        i:= i - 1;
      end;
    end else
      temp:= daysofmonth(y, i);
    offset:= offset + temp;
    Inc(i);
  end;

  offset:= offset + objDate.Day - 1;
  if (m = leap) and objDate.isLeap then  //若为闰月，再加上前一个非闰月天数
    offset:= offset + DaysOfMonth(y, m);

  // 该年到 2000.1.1 这几年的天数
  if y > 2000 then
  begin
    i:= 2000;
    j:= y - 1;
  end
  else begin
    i:= y;
    j:= 1999;
  end;

  temp:= 0;
  for t:= i to j do
  begin
    temp:= temp + DaysOfLunarYear(t);
  end;

  if y > 1999 then offset:= offset + temp
  else offset:= offset - temp;

  //农历二零零零年大年初一的阳历为 2000.2.5
  Result:= incDay(EncodeDate(2000,2,5),offset);
end;

// 检查农历日期是否合法
function TLssCalendar.ChkHzDate(objDate: THzDate): Boolean;
begin
  if (objDate.Year > 2099) or (objDate.Year < 1901)
    or (objDate.Month > 12) or (objDate.Day > 30) then
  begin
    Result:= False;
    exit;
  end;

  Result:= True;
  if objDate.isLeap then
  begin
    if leapMonth(objDate.Year) = objDate.Month then
    begin
      if DaysOfleapMonth(objDate.Year) < objDate.Day then
        Result:= False;
    end else Result:= False;
  end else
  begin
    if DaysOfMonth(objDate.Year,objDate.Month) < objDate.Day then
      Result:= False;
  end;
end;

// 某年的第n个节气为几日(从0小寒起算)
function TLssCalendar.sTerm(y, n: integer): TDateTime;
var
  temp: TDateTime;
  t: real;
  i: Int64;
begin
  t:= sTermInfo[n];
  t:= t * 60000;
  t:= t + 31556925974.7 * (y - 1900);
  i:= Round(t);
  Temp:= IncMilliSecond(EncodeDateTime(1900,1,6,2,5,0,0),i);
  Result:= temp;
end;

//传入干支y年,返回生肖
function TLssCalendar.GetAnimal(y: integer): string;
begin
  Result := Animals[y mod 12];
end;

// 传入 offset 返回干支, 0=甲子
function TLssCalendar.cyclical(num: integer): string;
begin
   Result:= Gan[num mod 10] + Zhi[num mod 12];
end;

function TLssCalendar.FormatLunarDay(day:integer): string;
begin
  case day of
    1..10: Result:= nStr2[0] + nStr1[day];
    11..19: Result:= nStr2[1] + nStr1[day - 10];
    20: Result:= nStr1[2] + nStr1[10];
    21..29: Result:= nStr2[2] + nStr1[day - 20];
    30: Result:= nStr1[3] + nStr1[10];
    else Result :='';
  end;
end;

function TLssCalendar.FormatLunarMonth(month:integer;isLeap:boolean): string;
begin
  case month of
    1: Result:= '正';
    2..10: Result:= nStr1[month];
    11: Result:= nStr1[10] + nStr1[month - 10]; //Result:= '冬';
    12: Result:= '腊';
    //11..12: Result:= nStr1[10] + nStr1[month - 10];
    else result :='';
  end;
  if isLeap then Result:= '闰' + Result;
  Result:= Result + '月';
end;

function TLssCalendar.FormatLunarYear(year:integer): string;
var
  temp: integer;
  zero: string;
begin
  zero:= '零';

  temp:= year div 1000;
  Result:= nStr1[temp];
  year:= year - temp * 1000;

  if year >= 100 then
  begin
    temp:= year div 100;
    Result:= Result + nStr1[temp];
    year:= year - temp * 100;
  end
  else
    Result:= Result + zero;

  if year >= 10 then
  begin
    temp:= year div 10;
    Result:= Result + nStr1[temp];
    year:= year - temp * 10;
  end
  else
  Result:= Result + zero;

  if year = 0 then Result:= Result + zero else
    Result:= Result + nStr1[year];
  Result:= Result + '年';
end;

//汉字星期几
function TLssCalendar.FormatWeekDay(WeekDay:integer): string;
begin
  Result := '星期' + nStr1[WeekDay mod 7];
end;

// 取得指定日期的节气
function TLssCalendar.GetJQ(TheDate: TDate): string;
var
  jq: Integer;
  term: TDateTime;
begin
  Result:= '';
  jq:= (MonthOf(TheDate) - 1) * 2;
  term:= sTerm(Yearof(TheDate), jq);     //节气时间
  if DateOf(term) = TheDate then Result:= solarTerm[jq]
  else
  begin
    term:= sTerm(Yearof(TheDate), jq + 1); //中气时间
    if DateOf(term) = TheDate then Result:= solarTerm[jq+1];
  end;
end;

//取得当日的节日
function TLssCalendar.GetFtv(TheDate: TDate): string;
var
  TempColor: TColor;
begin
  Result := GetFtv(TheDate, TempColor);
end;

//取得当日的节日
function TLssCalendar.GetFtv(TheDate: TDate; var fcolor: TColor): string;
var
  HzDate, HzDate2: THzDate;
  TempColor: TColor;
  TempStr: string;
begin
  Result := '';
  TempStr := '';
  fcolor := -1;

  HzDate := ToLunar(TheDate);
  HzDate2 := ToLunar(TheDate + 1);
  if HzDate.Month <> HzDate2.Month then   //针对"0100"除夕
  begin
    HzDate2.Day := 0;
    TempStr := FFtvList.GetLunarFtv(HzDate2, TempColor);
  end;

  if TempStr <> '' then
  begin
    fcolor := TempColor;
    Result := TempStr;
  end;
  
  TempStr := FFtvList.GetLunarFtv(HzDate, TempColor);
  if (TempStr <> '') then
  begin
    if fcolor = -1 then fcolor := TempColor;
    Result := Trim(Result + ' ' + TempStr);
  end;

  TempStr := FFtvList.GetSolarFtv(TheDate, TempColor);
  if (TempStr <> '') then
  begin
    if fcolor = -1 then fcolor := TempColor;
    Result := Trim(Result + ' ' + TempStr);
  end;

  TempStr := FFtvList.GetWeekFtv(TheDate, TempColor);
  if (TempStr <> '') then
  begin
    if fcolor = -1 then fcolor := TempColor;
    Result := Trim(Result + ' ' + TempStr);
  end;
end;

//取得当日的标记
function TLssCalendar.GetMark(TheDate: TDate): TColor;
var
  HzDate: THzDate;
begin
  HzDate := ToLunar(TheDate);
  Result := FFtvList.GetLunarMark(HzDate);
  if Result > -1 then Exit;
  Result := FFtvList.GetSolarMark(TheDate);
  if Result > -1 then Exit;
  Result := FFtvList.GetWeekMark(TheDate);
end;

{
//存储星座配信息
1白羊座： 03月21日-------04月19日  Aries
2金牛座： 04月20日-------05月20日  Taurus
3双子座： 05月21日-------06月21日  Gemini
4巨蟹座： 06月22日-------07月22日  Cancer
5狮子座： 07月23日-------08月22日  Leo
6处女座： 08月23日-------09月22日  Virgo
7天秤座： 09月23日-------10月23日  Libra
8天蝎座： 10月24日-------11月21日  Scorpio
9射手座： 11月22日-------12月21日  Sagittarius
10摩羯座： 12月22日-------01月19日  Capricorn
11水瓶座： 01月20日-------02月18日  Aquarius
12双鱼座： 02月19日-------03月20日  Pisces
}
//根据公历日期，返回星座
Function TLssCalendar.Constellation(TheDate: TDate): String;
var
  y, m, d: Word;
Begin
  DecodeDate(TheDate, y, m, d);
  Case m Of
    1:
      Begin
        If d < 20 Then result := '摩羯座';
        If d >= 20 Then result := '水瓶座';
      End;
    2:
      Begin
        If d < 19 Then result := '水瓶座';
        If d >= 19 Then result := '双鱼座';
      End;
    3:
      Begin
        If d < 21 Then result := '双鱼座';
        If d >= 21 Then result := '白羊座';
      End;
    4:
      Begin
        If d < 20 Then result := '白羊座';
        If d >= 20 Then result := '金牛座';
      End;
    5:
      Begin
        If d < 21 Then result := '金牛座';
        If d >= 21 Then result := '双子座';
      End;
    6:
      Begin
        If d < 22 Then result := '双子座';
        If d >= 22 Then result := '巨蟹座';
      End;
    7:
      Begin
        If d < 23 Then result := '巨蟹座';
        If d >= 23 Then result := '狮子座';
      End;
    8:
      Begin
        If d < 23 Then result := '狮子座';
        If d >= 23 Then result := '处女座';
      End;
    9:
      Begin
        If d < 23 Then result := '处女座';
        If d >= 23 Then result := '天秤座';
      End;
    10:
      Begin
        If d < 24 Then result := '天秤座';
        If d >= 24 Then result := '天蝎座';
      End;
    11:
      Begin
        If d < 22 Then result := '天蝎座';
        If d >= 22 Then result := '射手座';
      End;
    12:
      Begin
        If d < 22 Then result := '射手座';
        If d >= 22 Then result := '摩羯座';
      End;
  End;
End;

//返回当日所在周数
function TLssCalendar.WeekOfYear(TheDate: TDate): integer;
var
  TempDate: TDate;
begin
  Result := WeekOfTheYear(TheDate);    //ISO8601 standard compliant 

  if FUseISO8601 then Exit;

    //由于WeekOfTheYear() 使用ISO 8601标准，每周为星期一到星期天.
    //现根据日历显示，调整为从星期天到星期六为一周
    if (Result > 50) and (MonthOf(TheDate) = 1) then
    begin
      Result := 1;
      if (DayOfTheWeek(TheDate) = 7) and (FormatDateTime('mm-dd',TheDate) <> '01-01') then
        inc(Result);
      exit;
    end;

    TempDate := EncodeDate(YearOf(TheDate), 1, 1);
    if (WeekOfTheYear(TempDate) > 50) and (DayOf