hxcalendar.pas

一个小的万年历程序

function ThxCalendar.StoreCalendarDate: Boolean;
begin
  Result := not FUseCurrentDate;
end;

function ThxCalendar.GetDateElement(Index: Integer): Integer;
var
  AYear, AMonth, ADay: Word;
begin
  DecodeDate(FDate, AYear, AMonth, ADay);
  case Index of
    1: Result := AYear;
    2: Result := AMonth;
    3: Result := ADay;
    else Result := -1;
  end;
end;

procedure ThxCalendar.SetDateElement(Index: Integer; Value: Integer);
var
  AYear, AMonth, ADay: Word;
begin
  if Value > 0 then
  begin
    DecodeDate(FDate, AYear, AMonth, ADay);
    case Index of
      1: if AYear <> Value then AYear := Value else Exit;
      2: if (Value <= 12) and (Value <> AMonth) then AMonth := Value else Exit;
      3: if (Value <= DaysThisMonth) and (Value <> ADay) then ADay := Value else Exit;
      else Exit;
    end;
    FDate := EncodeDate(AYear, AMonth, ADay);
    FUseCurrentDate := False;
    UpdateCalendar;
    Change;
  end;
end;

procedure ThxCalendar.SetStartOfWeek(Value: TDayOfWeek);
begin
  if Value <> FStartOfWeek then
  begin
    FStartOfWeek := Value;
    UpdateCalendar;
  end;
end;

procedure ThxCalendar.SetUseCurrentDate(Value: Boolean);
begin
  if Value <> FUseCurrentDate then
  begin
    FUseCurrentDate := Value;
    if Value then
    begin
      FDate := Date; { use the current date, then }
      UpdateCalendar;
    end;
  end;
end;

{ Given a value of 1 or -1, moves to Next or Prev month accordingly }
procedure ThxCalendar.ChangeMonth(Delta: Integer);
var
  AYear, AMonth, ADay: Word;
  NewDate: TDate;
  CurDay: Integer;
begin
  DecodeDate(FDate, AYear, AMonth, ADay);
  CurDay := ADay;
  if Delta > 0 then ADay := DaysPerMonth(AYear, AMonth)
  else ADay := 1;
  NewDate := EncodeDate(AYear, AMonth, ADay);
  NewDate := NewDate + Delta;
  DecodeDate(NewDate, AYear, AMonth, ADay);
  if DaysPerMonth(AYear, AMonth) > CurDay then ADay := CurDay
  else ADay := DaysPerMonth(AYear, AMonth);
  CalendarDate := EncodeDate(AYear, AMonth, ADay);
end;

procedure ThxCalendar.PrevMonth;
begin
  ChangeMonth(-1);
end;

procedure ThxCalendar.NextMonth;
begin
  ChangeMonth(1);
end;

procedure ThxCalendar.NextYear;
begin
  if IsLeapYear(Year) and (Month = 2) and (Day = 29) then Day := 28;
  Year := Year + 1;
end;

procedure ThxCalendar.PrevYear;
begin
  if IsLeapYear(Year) and (Month = 2) and (Day = 29) then Day := 28;
  Year := Year - 1;
end;

procedure ThxCalendar.UpdateCalendar;
var
  AYear, AMonth, ADay: Word;
  FirstDate: TDate;
begin
  FUpdating := True;
  try
    DecodeDate(FDate, AYear, AMonth, ADay);
    FirstDate := EncodeDate(AYear, AMonth, 1);
    FMonthOffset := 2 - ((DayOfWeek(FirstDate) - StartOfWeek + 7) mod 7); { day of week for 1st of month }
    if FMonthOffset = 2 then FMonthOffset := -5;
    MoveColRow((ADay - FMonthOffset) mod 7, (ADay - FMonthOffset) div 7 + 1,
      False, False);
    Invalidate;
  finally
    FUpdating := False;
  end;
end;

procedure ThxCalendar.WMSize(var Message: TWMSize);
var
  GridLines: Integer;
begin
  GridLines := 6 * GridLineWidth;
  DefaultColWidth := (Message.Width - GridLines) div 7;
  DefaultRowHeight := (Message.Height - GridLines) div 7;
end;
function ThxCalendar.DaysOfLunarYear(y: integer): integer;
var
  i, sum: integer;
begin
  sum:= 348;       //29 * 12
  i:= $8000;
  while i > $8 do
  begin
    if (lunarInfo[y - 1900] and i) > 0 then sum := sum + 1 ;
    i:= i shr 1;
  end;
  Result:= sum + DaysOfLeapMonth(y);
end;

// 返回农历 y年闰月的天数
function ThxCalendar.DaysOfLeapMonth(y: integer): integer;
begin
 if leapMonth(y) > 0 then
   if (lunarInfo[y - 1899] and $f) = $f then
     Result := 30
   else
     Result := 29
 else
   Result := 0;
end;

//返回农历 y年闰哪个月 1-12 , 没闰返回 0
function ThxCalendar.leapMonth(y: integer): integer;
var
  lm: Word;
begin
   lm:= lunarInfo[y - 1900] and $f;
   if lm = $f then Result:= 0 else Result:= lm;
end;

//返回农历 y年m月的天数
function ThxCalendar.DaysOfMonth(y, m: integer): integer;
var
  temp1, temp2, temp3: Word;
begin
  temp1:= lunarInfo[y - 1900];
  temp2:= $8000;
  if m > 1 then temp2:= $8000 shr (m - 1);
  temp3:= temp1 and temp2;
  if temp3 > 0 then
    Result:= 30
  else Result:= 29;
end;

//算出农历, 传入公历日期, 返回农历日期
function ThxCalendar.ToLunar(TheDate: TDate): THzDate;
var
  TheYear, TheMonth,leap, temp, offset: integer;
begin
  if (32 > TheDate) or (TheDate >= 73416) then    //73415=EncodeDate(2100,12,31)
  begin                                           //32 = EncodeDate(1900,1,31) 农历1900年1月1日
    Result.Year := 0;
    Result.Month:= 0;
    Result.Day := 0;
    Result.isLeap := False;
    exit;
  end;
  offset:= DaysBetween(32,TheDate);
  TheYear:= 1900;
  while offset > 0 do
  begin
    temp:= DaysOfLunarYear(TheYear);
    TheYear := theYear + 1;
    offset:= offset - temp;
  end;
  if offset < 0 then
  begin
    offset:= offset + temp;
    TheYear:= TheYear - 1;
  end;

  leap:= leapMonth(TheYear); //闰哪个月
  result.isLeap := False;
  TheMonth := 0;
  while offset >= 0 do
  begin
    TheMonth:= TheMonth + 1;
    temp:= DaysOfMonth(TheYear, TheMonth);
    offset:= offset - temp;     //减去该月天数
    if (offset >= 0) and (TheMonth = Leap) then  //如果还有剩余天数且本月有闰
    begin                                       //减去闰月天数；
      temp:= DaysOfLeapMonth(TheYear);
      offset:= offset - temp;
      if offset < 0 then
        result.isLeap := True;        //置闰月标志为真；
    end;
  end;
  if offset < 0 then
  begin
    offset:= offset + temp;
  end;
  Result.Year := TheYear;
  Result.Month:= TheMonth;
  Result.Day:= offset + 1;
end;

// 求年柱，月柱，日柱
// 年，月为农历数字，objDate为当天的公历日期
function ThxCalendar.GetGZ(y, m: integer; TheDate: TDate): TGzDate;
var
  term: TDate;
  sy, sm, sd: Word;
begin
  DecodeDate(TheDate, sy, sm, sd);
  term:= sTerm(sy, (sm - 1) * 2);  // 当月的节气日期

  //年柱 1900年立春后为庚子年(60进制36)
  Result.Year:= sy - 1900 + 36;
  //依立春日期调整年柱.立春日固定在公历2月
  if (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 ThxCalendar.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 ThxCalendar.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 ThxCalendar.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;

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

function ThxCalendar.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 ThxCalendar.FormatLunarMonth(month:integer;isLeap:boolean): string;
begin
  case month of
    1..10: Result:= nStr1[month];
    11..12: Result:= nStr1[10] + nStr1[month - 10];
    else result :='';
  end;
  if isLeap then Result:= '闰' + Result;
  Result:= Result + '月';
end;

function ThxCalendar.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 ThxCalendar.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 ThxCalendar.GetsFtv(TheDate: TDate): string;
var
 sf:string;
 jlsl:integer;
 begin
   for jlsl :=0 to 22 do
   begin
     sf:=formatdatetime('mmdd',TheDate);
     if sf=copy(sFtv[jlsl],1,4)then
     begin
       Result:=copy(sFtv[jlsl],5,length(sFtv[jlsl])-4);
     end;
   end;
end;
function ThxCalendar.GetlFtv(TheDate: ThzDate): string;
var
 sf,m,d:string;
 jlsl:integer;
 begin
   //HzDate := ToLunar(MyDate);
   for jlsl :=0 to 9 do
   begin
     if TheDate.month<10 then m:='0'+inttostr(TheDate.month)else m:=inttostr(TheDate.month);
     if TheDate.day=0 then d:='01';
     if TheDate.day<10 then d:='0'+inttostr(TheDate.day)else d:=inttostr(TheDate.day);
     sf:=m+d;
     if sf=copy(lFtv[jlsl],1,4)then
     begin
       Result:=copy(lFtv[jlsl],5,length(lFtv[jlsl])-4);
     end;
   end;
end;
end.