cncalendar.pas

小巧而强大！及少的内存和CPU占用集合了超多功能:万年历、世界时钟、定时运行、定时关机、等。

unit CnCalendar;
//
//  2004.09.08 增加背景图案功能 imgFile(图像文件名) FirstRowImg(第一行是否显示)
//  2004.09.09 增加背景显示月份功能，ShowMonth 是否显示
//
//

interface

uses Classes, Controls, Messages, Windows, Forms, Graphics, StdCtrls,
  Grids, ExtCtrls, SysUtils;

type
  TDayOfWeek = 0..6;

  TCnCalendar = class(TCustomGrid)
  private
    FDate: TDateTime;
    FMonthOffset: Integer;
    FMonthFontcolor: Tcolor;
    FOnChange: TNotifyEvent;
    FReadOnly: Boolean;
    FStartOfWeek: TDayOfWeek;
    FImgFile: string;
    FUpdating: Boolean;
    FFirstRowimg: Boolean;
    FShowMonth: Boolean;
    FUseCurrentDate: Boolean;
    function GetCellText(ACol, ARow: Integer): string;
    function GetDateElement(Index: Integer): Integer;
    procedure SetCalendarDate(Value: TDateTime);
    procedure SetDateElement(Index: Integer; Value: Integer);
    procedure SetStartOfWeek(Value: TDayOfWeek);
    procedure SetImgFile(Value: string);
    procedure SetFirstRowImg(Value: Boolean);
    procedure SetShowMonth(Value: Boolean);
    procedure SetMonthFontcolor(Value: Tcolor);
    procedure SetUseCurrentDate(Value: Boolean);
    function StoreCalendarDate: Boolean;
  protected
    procedure Change; dynamic;
    procedure ChangeMonth(Delta: Integer);
    procedure Click; override;
    function DaysPerMonth(AYear, AMonth: Integer): Integer; virtual;
    function DaysThisMonth: Integer; virtual;
    procedure DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState); override;
    function IsLeapYear(AYear: Integer): Boolean; virtual;
    function SelectCell(ACol, ARow: Longint): Boolean; override;
    procedure WMSize(var Message: TWMSize); message WM_SIZE;
  public
    constructor Create(AOwner: TComponent); override;
    property CalendarDate: TDateTime read FDate write SetCalendarDate stored StoreCalendarDate;
    property CellText[ACol, ARow: Integer]: string read GetCellText;
    procedure NextMonth;
    procedure NextYear;
    procedure PrevMonth;
    procedure PrevYear;
    procedure UpdateCalendar; virtual;
  published
    property Align;
    property Anchors;
    property BorderStyle;
    property Color;
    property Constraints;
    property Ctl3D;
    property Day: Integer index 3 read GetDateElement write SetDateElement stored False;
    property DragCursor;
    property DragKind;
    property DragMode;
    property Enabled;
    property Font;
    property GridLineWidth;
    property Month: Integer index 2 read GetDateElement write SetDateElement stored False;
    property ParentColor;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ReadOnly: Boolean read FReadOnly write FReadOnly default False;
    property FirstRowimg: Boolean read FFirstRowimg write SetFirstRowImg default False; // L.h.c
    property ShowMonth: Boolean read FShowMonth write SetShowMonth default True; // L.h.c
    property MonthFontcolor: Tcolor read FMonthFontcolor write SetMonthFontcolor default clRed; // L.h.c
    property ShowHint;
    property StartOfWeek: TDayOfWeek read FStartOfWeek write SetStartOfWeek;
    property ImgFile: string read FImgFile write SetImgFile;
    property TabOrder;
    property TabStop;
    property UseCurrentDate: Boolean read FUseCurrentDate write SetUseCurrentDate default True;
    property Visible;
    property Year: Integer index 1 read GetDateElement write SetDateElement stored False;
    property OnClick;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDock;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnStartDock;
    property OnStartDrag;
  end;

procedure Register;

var
  image1            : Tbitmap;

implementation

uses DateCn;

procedure Register;
begin
  RegisterComponents('CnCalendar', [TCnCalendar]);
end;

constructor TCnCalendar.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  { defaults }
  FUseCurrentDate := True;
  FixedCols := 0;
  FixedRows := 1;
  ColCount := 7;
  RowCount := 7;
  ScrollBars := ssNone;
  Options := Options - [goRangeSelect] + [goDrawFocusSelected];
  FDate := Date;
  ShowMonth := True;
  MonthFontcolor := clRed;
  UpdateCalendar;
  image1 := Tbitmap.Create;             //  Destroy
end;

procedure TCnCalendar.Change;
begin
  if Assigned(FOnChange) then FOnChange(Self);
end;

procedure TCnCalendar.Click;
var
  TheCellText       : string;
begin
  inherited Click;
  TheCellText := CellText[Col, Row];
  if TheCellText <> '' then Day := StrToInt(TheCellText);
end;

function TCnCalendar.IsLeapYear(AYear: Integer): Boolean;
begin
  Result := (AYear mod 4 = 0) and ((AYear mod 100 <> 0) or (AYear mod 400 = 0));
end;

function TCnCalendar.DaysPerMonth(AYear, AMonth: Integer): Integer;
const
  DaysInMonth       : array[1..12] of Integer = (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
begin
  Result := DaysInMonth[AMonth];
  if (AMonth = 2) and IsLeapYear(AYear) then Inc(Result); { leap-year Feb is special }
end;

function TCnCalendar.DaysThisMonth: Integer;
begin
  Result := DaysPerMonth(Year, Month);
end;

procedure TCnCalendar.DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState);
var
  TheText           : string;
  TheDate           : TDate;
  OldColor          : Tcolor;
  img1              : TImage;
begin
  img1 := TImage.Create(Self);
  img1.Width := Width;
  img1.Height := Height;
  if ImgFile = '' then
  begin
    image1.Height := Height;
    image1.Width := Width;
    image1.Canvas.Brush.Color := Color;
    image1.Canvas.FillRect(Rect(0, 0, Width, Height));
    image1.Canvas.Brush.Color := clBtnFace;
    image1.Canvas.FillRect(Rect(0, 0, Width, RowHeights[0]));
  end;

  img1.Canvas.CopyRect(img1.Canvas.ClipRect, image1.Canvas, Canvas.ClipRect);
  img1.Canvas.Font.Name := 'Arial Black';
  img1.Canvas.Font.Size := Height - Height div 7 - 12;
  img1.Canvas.Font.style := [fsItalic, fsBold];
  img1.Canvas.Font.Color := MonthFontcolor;
  img1.Canvas.Brush.style := bsClear;
  if ShowMonth then
    img1.Canvas.TextOut((Width - img1.Canvas.TextWidth(inttostr(Month))) div 2 - 10,
      -(Height div 7) * 2 + 10, inttostr(Month));

  if (ARow <> 0) or FirstRowimg then
    Canvas.CopyRect(ARect, img1.Canvas, ARect);

  TheText := CellText[ACol, ARow];
  OldColor := Canvas.Font.Color;
  if not (gdSelected in AState) then
    Canvas.Brush.style := bsClear;      // 透明
  if (TheText <> '') and (ARow > 0) and
    (Year >= 1901) and (Year <= 2050) then
  begin
    TheDate := EncodeDate(Year, Month, StrToInt(TheText));
    if CnDayOfDate(TheDate) = '初一' then
    begin
      TheText := TheText + ' ' + CnMonthOfDate(TheDate);
      Canvas.Font.Color := clRed;
    end
    else
    begin
      TheText := TheText + ' ' + CnDayOfDate(TheDate);
      Canvas.Font.Color := OldColor;
    end;
  end;

  with ARect, Canvas do
    TextRect(ARect, Left + (Right - Left - TextWidth(TheText)) div 2,
      Top + (Bottom - Top - TextHeight(TheText)) div 2, TheText);

  Canvas.Font.Color := OldColor;

  img1.Free;
end;

function TCnCalendar.GetCellText(ACol, ARow: Integer): string;
var
  DayNum            : Integer;
begin
  if ARow = 0 then                      { day names at tops of columns }
    Result := ShortDayNames[(StartOfWeek + ACol) mod 7 + 1]
  else
  begin
    DayNum := FMonthOffset + ACol + (ARow - 1) * 7;
    if (DayNum < 1) or (DayNum > DaysThisMonth) then
      Result := ''
    else
      Result := inttostr(DayNum);
  end;
end;

function TCnCalendar.SelectCell(ACol, ARow: Longint): Boolean;
begin
  if ((not FUpdating) and FReadOnly) or (CellText[ACol, ARow] = '') then
    Result := False
  else
    Result := inherited SelectCell(ACol, ARow);
end;

procedure TCnCalendar.SetCalendarDate(Value: TDateTime);
begin
  FDate := Value;
  UpdateCalendar;
  Change;
end;

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

function TCnCalendar.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 TCnCalendar.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 TCnCalendar.SetMonthFontcolor(Value: Tcolor); // L.h.c 04.09.10
begin
  FMonthFontcolor := Value;
  UpdateCalendar;
end;

procedure TCnCalendar.SetShowMonth(Value: Boolean); // L.h.c 04.09.09
begin
  FShowMonth := Value;
  UpdateCalendar;
end;

procedure TCnCalendar.SetFirstRowImg(Value: Boolean); // L.h.c 04.09.09
begin
  FFirstRowimg := Value;
  UpdateCalendar;
end;

procedure TCnCalendar.SetImgFile(Value: string); // L.h.c 04.09.08
var
  AR                : TRect;
begin
  if (Value <> '') and (FileExists(Value)) then
  begin
    image1.LoadFromFile(Value);
    FImgFile := Value;
  end
  else
  begin
    FImgFile := '';
  end;
  UpdateCalendar;
end;

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

procedure TCnCalendar.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 TCnCalendar.ChangeMonth(Delta: Integer);
var
  AYear, AMonth, ADay: Word;
  NewDate           : TDateTime;
  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 TCnCalendar.PrevMonth;
begin
  ChangeMonth(-1);
end;

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

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

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

procedure TCnCalendar.UpdateCalendar;
var
  AYear, AMonth, ADay: Word;
  FirstDate         : TDateTime;
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 TCnCalendar.WMSize(var Message: TWMSize);
var
  GridLines         : Integer;
begin
  GridLines := 6 * GridLineWidth;
  DefaultColWidth := (Message.Width - GridLines) div 7;
  DefaultRowHeight := (Message.Height - GridLines) div 7;
end;

end.