uworkcalendar.pas

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

    FMonthCaptionPanel.Top - FMonthCaptionPanel.Height -
    FMonthGrid.GridLineWidth*7 - 2)/(FMonthGrid.RowCount-1));

  ReDrawPanel(False);

end;

function TWorkCalendar.GetBeginWeekDayNum: Integer;
var
  i:Integer;
begin
  Result := 0;
  for i := 1 to 7 do
  begin
    if CHINESELONGWEEKDAY[i] = FBeginWeekDay then
    begin
      Result := i;
      Break;
    end;
  end;
end;

function TWorkCalendar.GetCaptionColor: TColor;
begin
  Result := FMonthCaptionPanel.Color;
end;

function TWorkCalendar.GetChineseDateString(
  aChineseDate: TChineseDate): string;
begin
  Result := CHINESESTEM[Ord(aChineseDate.yearcycle.stem)]+
      CHINESEZODIAC[Ord(aChineseDate.yearcycle.zodiac)]+'('+
      CHINESEZODIACEX[Ord(aChineseDate.yearcycle.zodiac)]+')年'+
      CHINESEMONTHNAME[aChineseDate.month-1]+CHINESEDAYNAME[aChineseDate.day];
end;

function TWorkCalendar.GetDaysInWorkMonth: Integer;
begin
  Result := DaysInMonth(FWorkMonth);
end;

function TWorkCalendar.GetFirstDateOfPanel: TDate;
var
  lBeginWeekDayNum,lFirstWeekDayOfMonth :Integer;
  DaysOfSpace:Integer;
begin
  lBeginWeekDayNum := BeginWeekDayNum;
  lFirstWeekDayOfMonth := DayOfTheWeek(FWorkMonth);
  if lBeginWeekDayNum > lFirstWeekDayOfMonth then
    DaysOfSpace := 7-(lBeginWeekDayNum-lFirstWeekDayOfMonth)
  else DaysOfSpace := lFirstWeekDayOfMonth - lBeginWeekDayNum;
  Result := FWorkMonth - DaysOfSpace;
end;

function TWorkCalendar.GetWeekOfMonth: Integer;
begin
  Result := Trunc((FWorkMonth + DaysInMonth(FWorkMonth) - FirstDateOfPanel + 1) / 7);
  if Result <> (FWorkMonth + DaysInMonth(FWorkMonth) - FirstDateOfPanel + 1) / 7 then
    Result := Result + 1;
end;

procedure TWorkCalendar.MonthGridDrawCell(Sender: TObject; ACol,
  ARow: Integer; Rect: TRect; State: TGridDrawState);
var
  WeekDayIndex:Integer;
  OldBKColor:TColor;
  OldFont:TFont;
  CDate:TDate;
  HexColor:string;
begin
  with (Sender as TStringGrid).Canvas do
  begin
    OldFont := TFont.Create;
    OldFont.Assign(Font);
    OldBKColor := Brush.Color;
    try
      if ARow=0 then //画标题
      begin
        WeekDayIndex := ((BeginWeekDayNum+ACol) Mod 7);
        if WeekDayIndex=0 then WeekDayIndex := 7;
        if WeekDayIndex in [6,7] then
        begin
          Font.Assign(FWeekendFont);
          Brush.Color := FWeekendBKColor;
        end else
        begin
          Font.Assign(FWeekCaptionFont);
          Brush.Color := FWeekCaptionBKColor;
        end;
        FillRect(Rect);
        TextOut(Rect.Left+2,Rect.Top+2,CHINESELONGWEEKDAY[WeekDayIndex]);
      end else
      begin
        CDate := CellToDate(ACol,ARow);
        HexColor := IntToHex(OldFont.Color,0);
        HexColor := StringOfChar('0',6-Length(HexColor));

        if MonthOf(CDate)<>MonthOf(FWorkMonth) then
          Font.Color := ColorDecrease(clWhite-FNormalDayColor,1.55)
        else
          Font.Color := FNormalDayColor;
        FillRect(Rect);  
        TextOut(Rect.Left+2,Rect.Top+2,IntToStr(DayOf(CDate)));
      end;
    finally
      Brush.Color := OldBKColor;
      Font.Assign(OldFont);
    end;
  end;
end;

procedure TWorkCalendar.ReDrawPanel(ResizeSelf: Boolean);
begin
  FRedrawing := True;
  FMonthGrid.Width := (FMonthGrid.DefaultColWidth+FMonthGrid.GridLineWidth)*FMonthGrid.ColCount+2;
  if not WeekCaptionAutoHeight then
    FMonthGrid.Height :=
      (FMonthGrid.DefaultRowHeight+FMonthGrid.GridLineWidth)*FMonthGrid.RowCount+2
  else
  begin
    FMonthGrid.RowHeights[0] := Max(ABS(WeekCaptionFont.Height),ABS(WeekendFont.Height))+4;
    FMonthGrid.Height :=
      (FMonthGrid.DefaultRowHeight+FMonthGrid.GridLineWidth)*
        (FMonthGrid.RowCount-1)+2+FMonthGrid.RowHeights[0];

  end;

  FMonthCaptionPanel.Width := FMonthGrid.Width;
  FMonthGrid.Top := FMonthCaptionPanel.Top + FMonthCaptionPanel.Height;

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

end;

procedure TWorkCalendar.SelfResize(Sender: TObject);
begin
  if FRedrawing then exit;
  PostMessage(Self.Handle,WM_MONTHPANELRESIZE,0,0);
end;

procedure TWorkCalendar.SetBeginWeekDay(const Value: string);
begin
  FBeginWeekDay := Value;
  FFirstDateOfPanel:=GetFirstDateOfPanel;
  FMonthGrid.Invalidate;
end;

procedure TWorkCalendar.SetBKColor(const Value: TColor);
begin
  if FBKColor = Value then exit;
  FBKColor := Value;
  FMonthGrid.Invalidate;
end;

procedure TWorkCalendar.SetCapitonColor(const Value: TColor);
begin
  if FMonthCaptionPanel.Color = Value then exit;
  FMonthCaptionPanel.Color := Value;
end;

procedure TWorkCalendar.SetDispalyChineseDay(const Value: Boolean);
begin
  FDispalyChineseDay := Value;
  FMonthGrid.Invalidate;
end;

procedure TWorkCalendar.SetHolidayColor(const Value: TColor);
begin
  if FHolidayColor = Value then exit;
  FHolidayColor := Value;
  FMonthGrid.Invalidate;
end;

procedure TWorkCalendar.SetHolidayWorkBKColor(const Value: TColor);
begin
  if FHolidayWorkBKColor = Value then exit;
  FHolidayWorkBKColor := Value;
  FMonthGrid.Invalidate;
end;

procedure TWorkCalendar.SetNormalDayColor(const Value: TColor);
begin
  if FNormalDayColor = Value then exit;
  FNormalDayColor := Value;
  FMonthGrid.Invalidate;
end;

procedure TWorkCalendar.SetNormalDayWorkBKColor(const Value: TColor);
begin
  if FNormalDayWorkBKColor = Value then exit;
  FNormalDayWorkBKColor := Value;
  FMonthGrid.Invalidate;
end;

procedure TWorkCalendar.SetSaturdayColor(const Value: TColor);
begin
  if FSaturdayColor = Value then exit;
  FSaturdayColor := Value;
  FMonthGrid.Invalidate;
end;

procedure TWorkCalendar.SetSundayColor(const Value: TColor);
begin
  if FSundayColor = Value then exit;
  FSundayColor := Value;
  FMonthGrid.Invalidate;
end;

procedure TWorkCalendar.SetWeekCaptionAutoHeight(const Value: Boolean);
begin
  if FWeekCaptionAutoHeight = Value then exit;
  FWeekCaptionAutoHeight := Value;
  ReDrawPanel(False);
end;

procedure TWorkCalendar.SetWeekCaptionBKColor(const Value: TColor);
begin
  if FWeekCaptionBKColor = Value then exit;
  FWeekCaptionBKColor := Value;
  FMonthGrid.Invalidate;
end;

procedure TWorkCalendar.SetWeekCaptionFont(const Value: TFont);
begin
  FWeekCaptionFont.Assign(Value);
  FMonthGrid.Invalidate;
end;

procedure TWorkCalendar.SetWeekendBKColor(const Value: TColor);
begin
  if FWeekendBKColor = Value then exit;
  FWeekendBKColor := Value;
  FMonthGrid.Invalidate;
end;

procedure TWorkCalendar.SetWeekendFont(const Value: TFont);
begin
  if FWeekendFont = Value then exit;
  FWeekendFont.Assign(Value);
  FMonthGrid.Invalidate;
end;

procedure TWorkCalendar.SetWorkMonth(const Value: TDate);
var
  lfChineseDate,llChineseDate:TChineseDate;
begin
  if not YearMonthEquation(Value,FWorkMonth) then
  begin
    FWorkMonth := EncodeDate(YearOf(Value),MonthOf(Value),1);
    FFirstDateOfPanel:=GetFirstDateOfPanel;
    ClearInfor;
    FLeftCaption.Caption := CAPTTIONSPACE+IntToStr(YearOf(FWorkMonth)) + '年'+
      IntToStr(MonthOf(FWorkMonth)) + '月';

    lfChineseDate:=ChineseDate(FWorkMonth);
    llChineseDate:=ChineseDate(FWorkMonth+DaysInMonth(FWorkMonth));

    FMonthCaptionPanel.Caption :=GetChineseDateString(lfChineseDate)+' 至 '
      +GetChineseDateString(llChineseDate)+CAPTTIONSPACE;

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

procedure TWorkCalendar.WeekendWorkColor(const Value: TColor);
begin
  if FWeekendWorkBKColor = Value then exit;
  FWeekendWorkBKColor := Value;
  FMonthGrid.Invalidate;
end;

{ TBeginWeekDayProperty }

function TBeginWeekDayProperty.GetAttributes: TPropertyAttributes;
begin
  Result := [paMultiSelect, paValueList,  paRevertable];

end;

procedure TBeginWeekDayProperty.GetValues(Proc: TGetStrProc);
var
  i:Integer;
begin
  inherited;
  for i := 1 to 7 do Proc(CHINESELONGWEEKDAY[i]);
end;

end.