umonthpanel.pas

支持公历、农历及公历转农历使用公式法（不是查表法）的日历控件

  FMonthGrid.Free;
  FMonthCaptionPanel.Free;
  FGridPopupMenu.Items.Clear;
  FGridPopupMenu.Free;
  inherited;
end;

function TMonthPanel.GetRowHeight: Integer;
begin
  Result := FMonthGrid.DefaultRowHeight;
end;

function TMonthPanel.GetColWidth: Integer;
begin
  Result := FMonthGrid.DefaultColWidth;
end;

function TMonthPanel.GetMonthCaptionHeight: Integer;
begin
  Result := FMonthCaptionPanel.Height;
end;

procedure TMonthPanel.ReDrawPanel(ResizeSelf:Boolean);
begin
  FRedrawing := True;
  FMonthGrid.Width := (FMonthGrid.DefaultColWidth+FMonthGrid.GridLineWidth)*FMonthGrid.ColCount+2;
  FMonthGrid.Height := (FMonthGrid.DefaultRowHeight+FMonthGrid.GridLineWidth)*FMonthGrid.RowCount+2;
  FMonthCaptionPanel.Width := FMonthGrid.Width;
  FMonthGrid.Top := FMonthCaptionPanel.Top + FMonthCaptionPanel.Height;


  FPriMonth.Top := 2;
  FNexMonth.Top := 2;

  FPriMonth.Left := 2;
  FNexMonth.Left := FMonthCaptionPanel.Width - 2 - FNexMonth.Width;

  if ResizeSelf then
  begin
    Self.Width := FMonthGrid.Width;
    Self.Height := FMonthGrid.Top + FMonthGrid.Height;
  end;  
  FRedrawing := False;
end;

procedure TMonthPanel.SetRowHeight(const Value: Integer);
begin
  if FMonthGrid.DefaultRowHeight <> Value then
  begin
    FMonthGrid.DefaultRowHeight := Value;
    ReDrawPanel;
  end;
end;

procedure TMonthPanel.SetColWidth(const Value: Integer);
begin
  if FMonthGrid.DefaultColWidth <> Value then
  begin
    FMonthGrid.DefaultColWidth := Value;
    ReDrawPanel;
  end;
end;

procedure TMonthPanel.SetHolidayColor(const Value: TColor);
begin
  if FHolidayColor <> Value then
  begin
    FHolidayColor := Value;
    FMonthGrid.Invalidate;
  end;
end;

procedure TMonthPanel.SetHolidayTextColor(const Value: TColor);
begin
  if FHolidayTextColor <> Value then
  begin
    FHolidayTextColor := Value;
    FMonthGrid.Invalidate;
  end;
end;

procedure TMonthPanel.SetMonthCaptionHeight(const Value: Integer);
begin
  if FMonthCaptionPanel.Height <> Value then
  begin
    FMonthCaptionPanel.Height := Value;
    ReDrawPanel;
  end;
end;

procedure TMonthPanel.SetNormalColor(const Value: TColor);
begin
  if FNormalColor <> Value then
  begin
    FNormalColor := Value;
    FMonthGrid.Invalidate;
  end;
end;

procedure TMonthPanel.SetNormalTextColor(const Value: TColor);
begin
  if FNormalTextColor <> Value then
  begin
    FNormalTextColor := Value;
    FMonthGrid.Invalidate;
  end;
end;

procedure TMonthPanel.SetWeekendCaptionColor(const Value: TColor);
begin
  if FWeekendCaptionColor <> Value then
  begin
    FWeekendCaptionColor := Value;
    FMonthGrid.Invalidate;
  end;
end;

procedure TMonthPanel.SetWeekendColor(const Value: TColor);
begin
  if FWeekendColor <> Value then
  begin
    FWeekendColor := Value;
    FMonthGrid.Invalidate;
  end;
end;

procedure TMonthPanel.SetWeekendTextColor(const Value: TColor);
begin
  if FWeekendTextColor <> Value then
  begin
    FWeekendTextColor := Value;
    FMonthGrid.Invalidate;
  end;
end;

function TMonthPanel.GetMonthCaptionColor: TColor;
begin
  Result := FMonthCaptionPanel.Color;
end;

procedure TMonthPanel.SetMonthCaptionColor(const Value: TColor);
begin
  FMonthCaptionPanel.Color := Value;
end;

function TMonthPanel.GetMonthCaptionFont: TFont;
begin
  Result := FMonthCaptionPanel.Font;
end;

procedure TMonthPanel.SetMonthCaptionFont(const Value: TFont);
begin
  FMonthCaptionPanel.Font.Assign(Value);
end;

procedure TMonthPanel.SelfResize(Sender: TObject);
begin
  inherited;

  if FRedrawing then exit;
  PostMessage(Self.Handle,WM_MONTHPANELRESIZE,0,0);
end;

//359,137
procedure TMonthPanel.DoWM_Resize(var Msg: TMessage);
begin
  if Self.Width < MP_MINWIDTH then
    Self.Width := MP_MINWIDTH;
  if Self.Height < MP_MINHEIGHT then
    Self.Height := MP_MINHEIGHT;

  FMonthGrid.DefaultColWidth := Round((Self.Width - 2 - FMonthGrid.GridLineWidth*7)/7);
  
  FMonthGrid.DefaultRowHeight := Round((Self.Height -
    FMonthCaptionPanel.Top - FMonthCaptionPanel.Height -
    FMonthGrid.GridLineWidth*7 - 2)/FMonthGrid.RowCount);

  ReDrawPanel(False);
end;

procedure TMonthPanel.SetMonthPanelDate(const Value: TDate);
var
  laDay:TDateTime;
  i:Integer;
  lWeekOfMonth:Integer;
  lChineseDate:TChineseDate;
begin
  if (YearOf(Value) = YearOf(FMonthPanelDate)) and
     (MonthOf(Value) = MonthOf(FMonthPanelDate)) then exit;

  ClearCellDays;
  ClearDayCells;
  ClearDaySigns;
  ClearDayInfors;

  FMonthPanelDate := EncodeDate(YearOf(Value),MonthOf(Value),1);

  FChineseNewYear := ChineseNewYear(YearOf(FMonthPanelDate));

  lChineseDate:=ChineseDate(FMonthPanelDate);

  FLeftCaption.Caption := '   '+IntToStr(YearOf(FMonthPanelDate)) + '年'+
    IntToStr(MonthOf(FMonthPanelDate)) + '月';


  FMonthCaptionPanel.Caption :=
    CHINESESTEM[Ord(lChineseDate.yearcycle.stem)]+
    CHINESEZODIAC[Ord(lChineseDate.yearcycle.zodiac)]+'('+
    CHINESEZODIACEX[Ord(lChineseDate.yearcycle.zodiac)]+')年'+
    CHINESEMONTHNAME[lChineseDate.month-1]+'   ';
  laDay := FMonthPanelDate;
  FDaysInMonth := DaysInMonth(FMonthPanelDate);

  if DayOfTheWeek(laDay)-1 <> 0 then
  begin
    for i := 0 to DayOfTheWeek(laDay)-1 do
    begin
      FMonthGrid.Cells[i,1] := '';
    end;

  end;

  lWeekOfMonth := RefreshMonthGrid;
  laDay := laDay + FDaysInMonth-1;

  if DayOfTheWeek(laDay) <> 7 then
  begin
    for i := DayOfTheWeek(laDay) to 6 do
    begin
      FMonthGrid.Cells[i,lWeekOfMonth] := '';
    end;
  end;

  if FMonthGrid.RowCount <> lWeekOfMonth + 1 then
  begin
    FMonthGrid.RowCount := lWeekOfMonth + 1;
    ReDrawPanel;
  end;


  
end;

procedure TMonthPanel.MonthGridDrawCell(Sender: TObject; ACol,
  ARow: Integer; Rect: TRect; State: TGridDrawState);
  procedure CalendarTextOut(Left,Top:Integer;Caption:string);
  var
    OrgFont:TFont;
    GreFont:TFont;
    SliptPos:Integer;
  begin
    OrgFont := TFont.Create;
    GreFont := TFont.Create;
    try
      OrgFont.Assign((Sender as TStringGrid).Canvas.Font);
      SliptPos := Pos(CALENDARSPLITE,Caption);
      if SliptPos = 0 then SliptPos := Length(Caption)+1;
      (Sender as TStringGrid).Canvas.Font.Name := FGregorianCalendarFont.Name;
      (Sender as TStringGrid).Canvas.Font.Size := FGregorianCalendarFont.Size;
      (Sender as TStringGrid).Canvas.TextOut(Left,Top,LeftStr(Caption,SliptPos-1));
      if SliptPos < (Length(Caption)+1) then
      begin
        GreFont.Assign((Sender as TStringGrid).Canvas.Font);
        (Sender as TStringGrid).Canvas.Font.Name := FLunarCalendarFont.Name;
        (Sender as TStringGrid).Canvas.Font.Size := FLunarCalendarFont.Size;
        (Sender as TStringGrid).Canvas.TextOut(
          Left+GetFontStringSize(
            GreFont,LeftStr(Caption,SliptPos-1)),Top+2,
              RightStr(Caption,Length(Caption)-SliptPos+1));
      end;
      (Sender as TStringGrid).Canvas.Font.Assign(OrgFont);
    finally
      OrgFont.Free;
      GreFont.Free;
    end;
  end;
begin
  if Trim(FMonthGrid.Cells[ACol,ARow]) = '' then exit;

  (Sender as TStringGrid).Canvas.Font := Self.Font;
  if FCellDays[ACol,ARow] = Trunc(Now) then
  begin
    with (Sender as TStringGrid).Canvas do
    begin
      Font.Color := clRed;
      Font.Style := Font.Style + [fsBold,fsItalic];
    end;
  end;

  with (Sender as TStringGrid).Canvas do
  begin
    case ARow of
      0:begin             //标题栏显示
        Font.Style := Font.Style + [fsBold];
        if ACol > 4 then
        begin
          Font.Color := WeekendTextColor;
          TextOut(Rect.Left+2,Rect.Top+2,(Sender as TStringGrid).Cells[ACol,ARow]);
        end else
        begin
          TextOut(Rect.Left+2,Rect.Top+2,(Sender as TStringGrid).Cells[ACol,ARow]);
        end;
      end;
    else
      begin
        if (FCellDays[ACol,ARow] = FChineseNewYear)  then
        begin      //春节或特殊日期显示
          Font.Style := Font.Style + [fsBold];
          if (gdSelected in State) and
            (not (gdFocused in State) or
            ([goDrawFocusSelected, goRowSelect] * (Sender as TStringGrid).Options <> [])) then
          begin
            Brush.Color := clHighlight;
            Font.Color := clYellow;
          end
          else
          begin
            Brush.Color := clMaroon;
            Font.Color := clYellow;
          end;
          FillRect(Rect);
          CalendarTextOut(Rect.Left+2,Rect.Top+2,(Sender as TStringGrid).Cells[ACol,ARow]);
        end else if FDaySigns[DayOf(FCellDays[ACol,ARow])] = dsHoliday then  //节假日显示
        begin
          if (gdSelected in State) and
            (not (gdFocused in State) or
            ([goDrawFocusSelected, goRowSelect] * (Sender as TStringGrid).Options <> [])) then
          begin
            Brush.Color := clHighlight;
            Font.Color := HolidayTextColor;
          end
          else
          begin
            Brush.Color := HolidayColor;
            Font.Color := HolidayTextColor;
          end;
          FillRect(Rect);
          CalendarTextOut(Rect.Left+2,Rect.Top+2,(Sender as TStringGrid).Cells[ACol,ARow]);
        end else if ACol > 4 then //没有特殊情况的周末显示情况
        begin
          if (gdSelected in State) and
            (not (gdFocused in State) or
            ([goDrawFocusSelected, goRowSelect] * (Sender as TStringGrid).Options <> [])) then
          begin
            Brush.Color := clHighlight;
            Font.Color := WeekendTextColor;
          end
          else
          begin
            Brush.Color := WeekendColor;
            Font.Color := WeekendTextColor;
          end;
          FillRect(Rect);
          CalendarTextOut(Rect.Left+2,Rect.Top+2,(Sender as TStringGrid).Cells[ACol,ARow]);

        end else
        begin  //普通显示情况
          if (gdSelected in State) and
            (not (gdFocused in State) or
            ([goDrawFocusSelected, goRowSelect] * (Sender as TStringGrid).Options <> [])) then
          begin
            Brush.Color := clHighlight;
            if FCellDays[ACol,ARow] <> Trunc(Now) then
              Font.Color := clHighlightText;
          end
          else
          begin
            Brush.Color := NormalColor;
            if FCellDays[ACol,ARow] <> Trunc(Now) then
              Font.Color := NormalTextColor;
          end;
          FillRect(Rect);
          CalendarTextOut(Rect.Left+2,Rect.Top+2,(Sender as TStringGrid).Cells[ACol,ARow]);
        end;
      end; //end arow>0
    end; //end case;
  end;//end with

end;

procedure TMonthPanel.ClearDaySigns;
var
  i:Integer;
begin
  for i := 1 to 31 do
  begin
    FDaySigns[i] := dsNormal;
  end;
end;

procedure TMonthPanel.SetDaySign(DayIndex: Integer; DaySign: TDaySign);
begin
  if DayIndex in [1..31] then
  begin
    FDaySigns[DayIndex] := DaySign;
  end;
end;

procedure TMonthPanel.ClearDayInfors;
var
  i:Integer;
begin
  for i := 1 to 31 do
  begin
    FDayInfors[i] := '';