uworkcalendar.pas

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

unit uWorkCalendar;
{$R *.res}

interface

uses
  Dialogs,
  ExtCtrls,Controls,Grids,StdCtrls,Classes,Windows,Graphics,DesignIntf,
  DesignEditors,Messages,uMoon;

const
  WM_MONTHPANELRESIZE = WM_USER + 73;
  MP_MINWIDTH = 359;
  MP_MINHEIGHT = 137;
  CAPTTIONSPACE = '  ';
  DEFAULTCOLWIDTH = 50;
  DEFAULTROWHEIGHT = 19;

type
  TBeginWeekDayProperty = class(TStringProperty)
  public
    function GetAttributes: TPropertyAttributes; override;
    procedure GetValues(Proc: TGetStrProc); override;
  end;

  TWorkCalendar = class(TPanel)
  private
    FRedrawing: Boolean;
    FWorkMonth: TDate;
    FBeginWeekDay: string;
    FDispalyChineseDay: Boolean;
    FFirstDateOfPanel:TDate;
    FWeekendBKColor: TColor;
    FWeekendFont: TFont;
    FWeekCaptionAutoHeight: Boolean;
    FWeekCaptionBKColor: TColor;
    FWeekCaptionFont: TFont;
    FSaturdayColor: TColor;
    FSundayColor: TColor;
    FNormalDayWorkBKColor: TColor;
    FHolidayColor: TColor;
    FWeekendWorkBKColor: TColor;
    FNormalDayColor: TColor;
    FHolidayWorkBKColor: TColor;
    FBKColor: TColor;
    procedure SetWorkMonth(const Value: TDate);
    procedure SelfResize(Sender: TObject);
    procedure DoWM_Resize(var Msg: TMessage); message WM_MONTHPANELRESIZE;
    procedure SetBeginWeekDay(const Value: string);
    procedure SetDispalyChineseDay(const Value: Boolean);
    function GetFirstDateOfPanel: TDate;
    function GetWeekOfMonth: Integer;
    function GetBeginWeekDayNum: Integer;
    function GetDaysInWorkMonth: Integer;
    procedure SetWeekendBKColor(const Value: TColor);
    procedure SetWeekendFont(const Value: TFont);
    procedure SetWeekCaptionAutoHeight(const Value: Boolean);
    procedure SetWeekCaptionBKColor(const Value: TColor);
    procedure SetWeekCaptionFont(const Value: TFont);
    procedure SetHolidayColor(const Value: TColor);
    procedure SetHolidayWorkBKColor(const Value: TColor);
    procedure SetNormalDayColor(const Value: TColor);
    procedure SetNormalDayWorkBKColor(const Value: TColor);
    procedure SetSaturdayColor(const Value: TColor);
    procedure SetSundayColor(const Value: TColor);
    procedure WeekendWorkColor(const Value: TColor);
    procedure SetBKColor(const Value: TColor);
    procedure SetCapitonColor(const Value: TColor);
    function GetCaptionColor: TColor;
  protected
    FMonthGrid:TStringGrid;
    FMonthCaptionPanel:TPanel;
    FLeftCaption:TLabel;
    //根据设定的各种尺寸大小重新摆放控件的位置以及设定大小
    procedure ReDrawPanel(ResizeSelf:Boolean = True);

    //清除显示、存储的数据
    procedure ClearInfor;

    procedure MonthGridDrawCell(Sender: TObject; ACol, ARow: Integer;
      Rect: TRect; State: TGridDrawState);
  public
    constructor Create(AOwner: TComponent);override;
    destructor Destroy;override;

    function GetChineseDateString(aChineseDate:TChineseDate):string;
    //根据所在格返回日期
    function CellToDate(ACol,ARow:Integer):TDate;
  published
    {MonthPanel所显示的年月}
    property WorkMonth :TDate read FWorkMonth Write SetWorkMonth;
    property BeginWeekDay :string read FBeginWeekDay write SetBeginWeekDay;
    property BeginWeekDayNum :Integer read GetBeginWeekDayNum;
    property DispalyChineseDay:Boolean read FDispalyChineseDay write SetDispalyChineseDay;
    property WeekOfMonth:Integer read GetWeekOfMonth;
    property FirstDateOfPanel:TDate read FFirstDateOfPanel;
    property DaysInWorkMonth : Integer read GetDaysInWorkMonth;

    property WeekendBKColor:TColor read FWeekendBKColor
      write SetWeekendBKColor default clbtnFace;
    property WeekendFont:TFont read FWeekendFont
      write SetWeekendFont;

    property WeekCaptionBKColor:TColor read FWeekCaptionBKColor
      write SetWeekCaptionBKColor default clbtnFace;
    //一般日期颜色
    property NormalDayColor:TColor read FNormalDayColor
      write SetNormalDayColor;
    //周日颜色
    property SundayColor:TColor read FSundayColor
      write SetSundayColor;
    //周六颜色
    property SaturdayColor:TColor read FSaturdayColor
      write SetSaturdayColor;
    //节假日颜色
    property HolidayColor:TColor read FHolidayColor
      write SetHolidayColor;
    //一般背景颜色
    property BKColor:TColor read FBKColor
      write SetBKColor;
    //工作日加班背景颜色
    property NormalDayWorkBKColor:TColor read FNormalDayWorkBKColor
      write SetNormalDayWorkBKColor;
    //周末加班背景颜色
    property WeekendWorkBKColor:TColor read FWeekendWorkBKColor
      write WeekendWorkColor;
    //节假日背景加班
    property HolidayWorkBKColor:TColor read FHolidayWorkBKColor
      write SetHolidayWorkBKColor;
    //标题颜色
    property CaptionColor:TColor read GetCaptionColor
      write SetCapitonColor;

    property WeekCaptionFont:TFont read FWeekCaptionFont
      write SetWeekCaptionFont;

    property WeekCaptionAutoHeight: Boolean read FWeekCaptionAutoHeight
      write SetWeekCaptionAutoHeight;
  end;

procedure Register;

implementation

uses DateUtils,SysUtils,Math,StrUtils;

procedure Register;
begin
  RegisterComponents('GiSun', [TWorkCalendar]);
  RegisterPropertyEditor(TypeInfo(string),TWorkCalendar,'BeginWeekDay',TBeginWeekDayProperty);
end;

function ColorDecrease(OrgColor:TColor;DecreaseRate:Double):TColor;
var
  HexColor:string;
begin
  HexColor := IntToHex(OrgColor,0);
  HexColor := StringOfChar('0',6-Length(HexColor))+HexColor;

  Result := RGB(Trunc(StrToInt('$'+RightStr(HexColor,2))/DecreaseRate),
                Trunc(StrToInt('$'+MidStr(HexColor,3,2))/DecreaseRate),
                Trunc(StrToInt('$'+LeftStr(HexColor,2))/DecreaseRate));
end;

function YearMonthEquation(Date1,Date2:TDate):Boolean;
begin
  Result := (YearOf(Date1) = YearOf(Date2)) and
     (MonthOf(Date1) = MonthOf(Date2));
end;

function GetFontStringSize(Font:TFont;Caption:string):Integer;
var
  SizeLabel:TLabel;
begin
  SizeLabel := Tlabel.Create(nil);
  try
    SizeLabel.Font.Assign(Font);
    SizeLabel.AutoSize := True;
    SizeLabel.Caption := Caption;
    Result := SizeLabel.Width;
  finally
    SizeLabel.Free;
  end;
end;

{ TWorkCalendar }

function TWorkCalendar.CellToDate(ACol, ARow: Integer): TDate;
begin
  if (ARow in [1..FMonthGrid.RowCount-1]) and
     (ACol in [0..FMonthGrid.ColCount-1]) then
  begin
    Result := (ARow-1)*7+ACol+FirstDateOfPanel;
  end else Result := 0;
end;

procedure TWorkCalendar.ClearInfor;
begin
  {todo:ClearInfor}
end;

constructor TWorkCalendar.Create(AOwner: TComponent);
begin
  inherited;

  FRedrawing := False;
  FDispalyChineseDay := False;
  FBeginWeekDay := CHINESELONGWEEKDAY[1];
  FFirstDateOfPanel:=GetFirstDateOfPanel;

  FWeekCaptionAutoHeight := True;
  FWeekendBKColor := clBtnFace;
  FWeekCaptionBKColor := clBtnFace;
  FNormalDayColor := clBlack;
  FSundayColor := clRed;
  FSaturdayColor := clBlue;
  FHolidayColor := clYellow;
  FBKColor := clWhite;
  FNormalDayWorkBKColor := ColorDecrease(FBKColor,1.05);
  FWeekendWorkBKColor := ColorDecrease(FBKColor,1.1);
  FHolidayWorkBKColor := ColorDecrease(FBKColor,1.15);

  FWeekendFont := TFont.Create;
  FWeekendFont.Name := '';
  FWeekendFont.Height := -12;
  FWeekendFont.Charset := GB2312_CHARSET;
  FWeekendFont.Color := clRed;
  FWeekendFont.Style := FWeekendFont.Style + [fsBold];

  FWeekCaptionFont := TFont.Create;
  FWeekCaptionFont.Name := '';
  FWeekCaptionFont.Height := -12;
  FWeekCaptionFont.Charset := GB2312_CHARSET;
  FWeekCaptionFont.Color := clBlack;
  FWeekCaptionFont.Style := FWeekCaptionFont.Style + [fsBold];

  Self.ParentCtl3D := False;
  Self.ParentFont := False;
  Self.Font.Name := '宋体';
  Self.Font.Height := -12;
  Self.Font.Charset := GB2312_CHARSET;
  Self.Font.Color := clBlack;
  Self.Ctl3D := False;
  Self.Caption := '';
  Self.BevelOuter := bvNone;

  FMonthGrid := TStringGrid.Create(Self);
  FMonthGrid.Ctl3D := False;
  FMonthGrid.Parent := Self;
  FMonthGrid.FixedRows := 1;
  FMonthGrid.FixedCols := 0;
  FMonthGrid.ColCount := 7;
  FMonthGrid.RowCount := 7;
  FMonthGrid.Left := 0;
  FMonthGrid.OnDrawCell := MonthGridDrawCell;
  FMonthGrid.DefaultColWidth := DEFAULTCOLWIDTH;
  FMonthGrid.DefaultRowHeight := DEFAULTROWHEIGHT;


  FMonthCaptionPanel := TPanel.Create(Self);
  FMonthCaptionPanel.Color := clGradientActiveCaption;
  FMonthCaptionPanel.Alignment := taRightJustify;
  FMonthCaptionPanel.Font.Name := '宋体';
  FMonthCaptionPanel.Font.Size := -9;
  FMonthCaptionPanel.Font.Color := clYellow;
  FMonthCaptionPanel.Font.Style := FMonthCaptionPanel.Font.Style + [fsBold];
  FMonthCaptionPanel.Ctl3D := False;
  FMonthCaptionPanel.Parent := Self;
  FMonthCaptionPanel.Left := 0;
  FMonthCaptionPanel.Top := 0;
  FMonthCaptionPanel.Height := 17;

  FLeftCaption := TLabel.Create(Self);
  FLeftCaption.Parent := FMonthCaptionPanel;
  FLeftCaption.Align := alLeft;

  Self.OnResize := SelfResize;
  WorkMonth := EncodeDate(YearOf(Now),MonthOf(Now),1);
end;

destructor TWorkCalendar.Destroy;
begin
  FLeftCaption.Free;
  FMonthGrid.Free;
  FMonthCaptionPanel.Free;
  FWeekendFont.Free;
  FWeekCaptionFont.Free;
  inherited;
end;

procedure TWorkCalendar.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 - FMonthGrid.RowHeights[0]-