lsscalendar.pas

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

      if not IsRectEmpty(FLunarRect) then
      begin
        if (FLunarCalStyle = csRight) and FShowVertical then
          LunarTextFont.Size := GetMaxTextSize('九', FLunarRect.Right - FLunarRect.Left, (FLunarRect.Bottom - FLunarRect.Top) div 3)
        else
          LunarTextFont.Size := GetMaxTextSize('九九九',FLunarRect.Right - FLunarRect.Left, FLunarRect.Bottom - FLunarRect.Top)
      end;
      if not IsRectEmpty(FFtvRect) then
      begin
        if FFtvCalStyle = csRight then
          if FShowVertical then
            FtvTextFont.Size := GetMaxTextSize('九', FFtvRect.Right - FFtvRect.Left, (FFtvRect.Bottom - FFtvRect.Top) div 3)
          else
            FtvTextFont.Size := GetMaxTextSize('九九九',FFtvRect.Right - FFtvRect.Left, FFtvRect.Bottom - FFtvRect.Top)
        else
          FtvTextFont.Size := GetMaxTextSize('九九九九九九',FFtvRect.Right - FFtvRect.Left, FFtvRect.Bottom - FFtvRect.Top);
      end;
    end;

    //计算最大可以显示节日字符串长度
    MaxFtvLen := 6;
    if not IsRectEmpty(FFtvRect) then
      if ((FFtvCalStyle = csRight) and not FShowVertical) or
         (FFtvCalStyle <> csRight) then
      begin
        S := '九九九';
        Canvas.Font.Size := FtvTextFont.Size;
        repeat
          S := S + '九';
          TextSize := Canvas.TextExtent(S);
        until (TextSize.cx > FFtvRect.Right - FFtvRect.Left) or (TextSize.cy > FFtvRect.Bottom - FFtvRect.Top);
        MaxFtvLen := length(S) - 2;
      end;
  end;

  if FShowArrow then
  begin
    Canvas.Font.Assign(FCalColors.TitleTextFont);
    Canvas.Font.Size := FCalColors.TitleTextFont.Size * 3 div 5;
    TextSize := Canvas.TextExtent('《');

    FPrevYearRect.Left := FTitleRect.Left + 5;
    FPrevYearRect.Right := FPrevYearRect.Left + TextSize.cx;
    FPrevYearRect.Top := (FTitleRect.Bottom - TextSize.cy) div 2;
    FPrevYearRect.Bottom := FPrevYearRect.Top + TextSize.cy;

    FPrevMonthRect := FPrevYearRect;
    FPrevMonthRect.Left := FPrevYearRect.Right + 1;
    FPrevMonthRect.Right := FPrevMonthRect.Left + TextSize.cx;

    FNextYearRect := FPrevYearRect;
    FNextYearRect.Right := FTitleRect.Right - 5;
    FNextYearRect.Left := FNextYearRect.Right - TextSize.cx;

    FNextMonthRect := FNextYearRect;
    FNextMonthRect.Right := FNextYearRect.Left - 1;
    FNextMonthRect.Left := FNextMonthRect.Right - TextSize.cx;
  end;
end;

function TLssCalendar.CalcDayRect(ADate: TDate): TRect;
var
  DateOffset:integer;
  Col,Row:integer;
begin
  dateOffset := DaysBetween(ADate , FFirstDate);
  Row := DateOffset div 7;
  Col := DateOffset mod 7;
  Result.Left := FDaysRect.Left + FCellWidth * col;
  Result.Top := FDaysRect.Top + FCellHeight * Row;
  Result.Right := Result.Left + FCellWidth;
  Result.Bottom := Result.Top + FCellHeight;
end;

function TLssCalendar.GetMaxTextSize(S:String;W,H:integer):integer;
var
  n: integer;
  TextSize :TSize;
begin
  for n := 5 to 1000 do
  begin
    Canvas.Font.Size := n;
    TextSize:= Canvas.TextExtent(S);
    if (TextSize.cx > W) or (TextSize.cy > H) then break;
  end;
  Result := n - 1 ;
end;

procedure TLssCalendar.GetFirstDay;
var
  DayOffSet:integer;
  y, m, d: Word;
begin
  DecodeDate(FViewDate,y, m, d);
  FFirstDate :=  EnCodeDate(y,m,1);
  if FUseISO8601 then
    DayOffset := DayOfTheWeek(FFirstDate)
  else
    DayOffset := DayOfWeek(FFirstDate);
  if DayOffset = 1 then DayOffSet := 8;   //保证前面包含上月数据
  FFirstDate := IncDay(FFirstDate, 1-DayOffset);
end;

procedure TLssCalendar.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  inherited;
  if not (csDesigning in ComponentState) then SetFocus;
  if Button = mbLeft then
  begin
    if ptInRect(FDaysRect,Point(X,Y)) then
    begin
      UpdateHighlight(X, Y);
      Exit;
    end;

    if FShowArrow then
    begin
    if ptInRect(FPrevYearRect,Point(X,Y)) then
    begin
      SetDate(IncYear(FViewDate, -1 ) );
    end
    else if ptInRect(FPrevMonthRect,Point(X,Y)) then
    begin
      SetDate(IncMonth(FViewDate, -1 ) );
    end
    else if ptInRect(FNextMonthRect,Point(X,Y)) then
    begin
      SetDate(IncMonth(FViewDate, 1 ) );
    end
    else if ptInRect(FNextYearRect,Point(X,Y)) then
    begin
      SetDate(IncYear(FViewDate, 1 ) );
    end;
    end;
  end;
end;

procedure TLssCalendar.MouseMove( Shift: TShiftState; X, Y: Integer );
Var
  rt: TRect;
  sFtv: string;
  col,row: integer;
  TempDate: TDate;
  HzDate:THzDate;
  GzDate:TGzDate;
begin
  inherited;
  if ssLeft in Shift then UpdateHighlight(X, Y);

  if not ShowHint then Exit;

  if ptInRect(FDaysRect,Point(X,Y)) then
  begin
    col := X div FCellWidth;
    Row := (Y - FDaysRect.Top) div FCellHeight;
    rt.Left := FDaysRect.Left + FCellWidth * col;
    rt.Top := FDaysRect.Top + FCellHeight * Row;
    rt.Right := rt.Left + FCellWidth;
    rt.Bottom := rt.Top + FCellHeight;

  TempDate := FFirstDate + col + row * 7;
  Hzdate:=ToLunar(TempDate);
  Gzdate := GetGz(TempDate);

    If Not CHint.Visible Then
      CHint.Show;

    if (FOldViewRect.Left = rt.Left) and (FOldViewRect.Top = rt.Top) then
      Exit;
    FOldViewRect := rt;

  CHint.SetPosition;
  CHint.Caption := '公元= ' + FormatDateTime('yyyy年m月d日 dddd',TempDate) + '  第' + IntToStr(WeekOfYear(TempDate)) + '周' //+ Constellation(TempDate)  + ' --- '  + IntToStr(DayOfTheWeek(Date)) + ' ' + IntToStr(WeekOfTheYear(TempDate)) + '/' + IntToStr(WeeksInYear(TempDate))
       + #10 + '农历= '+FormatLunarYear(hzdate.Year) + FormatLunarMonth(hzdate.Month,IsRightToLeft) + FormatLunarDay(hzdate.Day)
       + #10 + '干支= ' + Cyclical(GZdate.Year) + '(' + GetAnimal(GzDate.year) + ')年' + Cyclical(GzDate.Month) + '月' + Cyclical(Gzdate.day) + '日';
  sFtv := GetFtv(TempDate);
  if sFtv <> '' then
    CHint.Caption := CHint.Caption + #10 + '节日= ' + sFtv;
  end
  else if FShowArrow then
  begin
    if ptInRect(FPrevYearRect,Point(X,Y)) then
    begin
      CHint.Show;
      CHint.SetPosition;
      CHint.Caption := '上一年';
    end
    else if ptInRect(FPrevMonthRect,Point(X,Y)) then
    begin
      CHint.Show;
      CHint.SetPosition;
      CHint.Caption := '上一月';
    end
    else if ptInRect(FNextMonthRect,Point(X,Y)) then
    begin
      CHint.Show;
      CHint.SetPosition;
      CHint.Caption := '下一月';
    end
    else if ptInRect(FNextYearRect,Point(X,Y)) then
    begin
      CHint.Show;
      CHint.SetPosition;
      CHint.Caption := '下一年';
    end
    else
    begin
      CHint.Hide;
      exit;
    end;
  end
  else
  begin
    CHint.Hide;
    exit;
  End;
end;

procedure TLssCalendar.MouseLeave(Var Msg: TMessage);
begin
  CHint.Hide;
end;

procedure TLssCalendar.MouseUp( Button: TMouseButton; Shift: TShiftState; X, Y: Integer );
begin
  inherited;
  if Button = mbLeft then
  begin
    FNeedUpdate := False;
  end;
end;

procedure TLssCalendar.CMWantSpecialKey(var Message: TCMWantSpecialKey);
begin
  inherited;
  if Message.CharCode in [vk_Left..vk_Down] then Message.Result := 1;
end;

procedure TLssCalendar.KeyDown( var Key: Word; Shift: TShiftState );
var
  D, M, Y: Word;
begin
  inherited;
  if Shift = [] then
  begin
    FNeedUpdate := True;
    case Key of
      vk_Up:    SetDate(FViewDate - 7);
      vk_Down:  SetDate(FViewDate + 7);
      vk_Left:  SetDate(FViewDate - 1);
      vk_Right: SetDate(FViewDate + 1);
      vk_Home:  begin
                  DecodeDate(FViewDate, Y, M, D );
                  SetDate(EncodeDate( Y, M, 1 ));
                end;

      vk_End:   begin
                  DecodeDate(IncMonth(FViewDate, 1 ), Y, M, D );
                  SetDate(EncodeDate( Y, M, 1 ) - 1 );
                end;
      vk_Prior: SetDate(IncMonth(FViewDate, -1 ) );
      vk_Next:  SetDate(IncMonth(FViewDate, 1 ) );
    end;

    if Key = vk_Return then
      inherited Click;
  end;
end; {= TLssCalendar.KeyDown =}

procedure TLssCalendar.UpdateHighlight( X, Y: Integer );
var
  col,row: integer;
  TempDate: TDate;
begin
  if ptInRect(FDaysRect,Point(X,Y)) then
  begin
    col := x div FCellWidth;
    Row := (Y - FDaysRect.Top) div FCellHeight;
    TempDate := FFirstDate + col + row * 7;
    if TempDate <> FViewDate then
    begin
      FNeedUpdate := True;
      SetDate(TempDate);
    end;
  end;
end;

procedure TLssCalendar.Changed;
begin
  if Assigned(FOnChange) then FOnChange( Self );
end;

function TLssCalendar.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 TLssCalendar.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 TLssCalendar.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 TLssCalendar.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 TLssCalendar.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;
  Temp := 0;
  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;

// 求年柱，月柱，日柱
//TheDate为当天的公历日期
function TLssCalendar.GetGZ(TheDate: TDate): TGzDate;
var
  term: TDate;