?»??»?unit MyCalendar;

interface

uses Classes, Controls, Messages, Windows, Forms, Graphics, StdCtrls,
  Grids, SysUtils, Extctrls, Dialogs, Buttons;

type
  TDayOfWeek = 0..6;
  TMyCalendar = class(TCustomGrid)
  private
    FSelDates: TStringList;
    FPYBtn: TBitBtn;
    FPMBtn: TBitBtn;
    FNYBtn: TBitBtn;
    FNMBtn: TBitBtn;
    FDate: TDateTime;
    FMonthOffset: Integer;
    FOnChange: TNotifyEvent;
    FOnDayChange: TNotifyEvent;
    FOnAfterClick: TNotifyEvent;
    FReadOnly: Boolean;
    FStartOfWeek: TDayOfWeek;
    FUpdating: Boolean;
    FUseCurrentDate: Boolean;
    FShortDateName: 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 SetShortDateName(Value: Boolean);
    procedure SetUseCurrentDate(Value: Boolean);
    function StoreCalendarDate: Boolean;
    procedure SetSelDates(value:TStringList);
  protected
    procedure Change; dynamic;
    procedure DayChange; dynamic;
    procedure AfterClick; 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;
    procedure MouseDownPY(Sender: TObject;Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
    procedure MouseDownPM(Sender: TObject;Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
    procedure MouseDownNY(Sender: TObject;Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
    procedure MouseDownNM(Sender: TObject;Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
    procedure Invalidate; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; 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 BorderStyle;
    property Color;
    property Ctl3D;
    property Day: Integer index 3  read GetDateElement write SetDateElement stored False;
    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 ShortDateName: Boolean read FShortDateName write SetShortDateName default False;
    property ShowHint;
    property StartOfWeek: TDayOfWeek read FStartOfWeek write SetStartOfWeek;
    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 SelectedDates: TStringList read FSelDates write SetSelDates;
    property OnClick;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
    property OnDayChange: TNotifyEvent read FOnDayChange write FOnDayChange;
    property OnAfterClick: TNotifyEvent read FOnAfterClick write FOnAfterClick;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnStartDrag;
  end;

procedure Register;
  const
    FSDateNames: array[1..7] of string =
                 ('Sun.','Mon.','Tue.','Wed.','Thu.','Fri.','Sat.');
    FLDateNames: array[1..7] of string =
                 ('¬P´Á¤é','¬P´Á¤@','¬P´Á¤G','¬P´Á¤T','¬P´Á¥|','¬P´Á¤­','¬P´Á¤»');

implementation

procedure Register;
begin
  RegisterComponents('Samples', [TMyCalendar]);
end;

constructor TMyCalendar.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  { defaults }
  FSelDates:=TStringList.Create;
  FPYBtn:=TBitBtn.Create(self);
  FPYBtn.Parent:=self;
  FPYBtn.Font.Color:=clRed;
  FPYBtn.Caption:='¡Õ¡Õ';
  FPYBtn.Hint:='«e¤@¦~';
  FPYBtn.ShowHint:=True;
  FPYBtn.OnMouseDown:=MouseDownPY;
  FPMBtn:=TBitBtn.Create(self);
  FPMBtn.Parent:=self;
  FPMBtn.Font.Color:=clNavy;
  FPMBtn.Caption:='¡Õ';
  FPMBtn.Hint:='«e¤@¤ë';
  FPMBtn.ShowHint:=True;
  FPMBtn.OnMouseDown:=MouseDownPM;
  FNYBtn:=TBitBtn.Create(self);
  FNYBtn.Parent:=self;
  FNYBtn.Font.Color:=clRed;
  FNYBtn.Caption:='¡Ö¡Ö';
  FNYBtn.Hint:='«á¤@¦~';
  FNYBtn.ShowHint:=True;
  FNYBtn.OnMouseDown:=MouseDownNY;
  FNMBtn:=TBitBtn.Create(self);
  FNMBtn.Parent:=self;
  FNMBtn.Font.Color:=clNavy;
  FNMBtn.Caption:='¡Ö';
  FNMBtn.Hint:='«á¤@¤ë';
  FNMBtn.ShowHint:=True;
  FNMBtn.OnMouseDown:=MouseDownNM;

  FUseCurrentDate := True;
  FixedCols := 0;
  FixedRows := 2;
  ColCount := 7;
  RowCount := 8;
  Width := 265;
  Height:= 170;
  ScrollBars := ssNone;
  Options := Options - [goRangeSelect] + [goDrawFocusSelected];
  FDate := Date;
  UpdateCalendar;
end;

destructor TMyCalendar.Destroy;
begin
  FSelDates.Free;
  FPYBtn.Free;
  FPMBtn.Free;
  FNYBtn.Free;
  FNMBtn.Free;
  inherited Destroy;
end;

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

procedure TMyCalendar.AfterClick;
begin
  if Assigned(FOnAfterClick) then FOnAfterClick(Self);
end;

procedure TMyCalendar.DayChange;
begin
  if Assigned(FOnDayChange) then FOnDayChange(Self);
end;

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

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

function TMyCalendar.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 TMyCalendar.DaysThisMonth: Integer;
begin
  Result := DaysPerMonth(Year, Month);
end;

procedure TMyCalendar.DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState);
var
  TheText: string;
  SundayCol: integer;
  SelDateCount: integer;
  Counter: integer;
  DumDate: TDateTime;
  DRect: TRect;
begin
  DRect:= ARect;
  if ARow=0 then begin
     DRect.Top:=0;DRect.Left:=0;DRect.Right:=7*ColWidths[0]+6*GridLineWidth;
     DRect.Bottom:=RowHeights[0];
{     case Acol of
        2:TheText:=Trim(inttostr(GetDateElement(1)))+'¦~';
        3:TheText:=Trim(inttostr(GetDateElement(2)))+'¤ë';
        4:TheText:=Trim(inttostr(GetDateElement(3)))+'¤é';
     else
        TheText:='';
     end;}
     if FShortDateName then TheText:=Trim(DateToStr(FDate))
     else TheText:=Trim(inttostr(GetDateElement(1)))+'¦~'+
          Trim(inttostr(GetDateElement(2)))+'¤ë'+
          Trim(inttostr(GetDateElement(3)))+'¤é';
     end
  else begin
     TheText := CellText[ACol, ARow];
  end;
  if FStartOfWeek=0 then SundayCol:=0
  else SundayCol:=7-StartOfWeek;
  with DRect, Canvas do begin
    Canvas.Font.color:=clBlack;
    if ((ARow>1)and(TheText<>'')and(FSelDates.Count>0)) then begin
       DumDate:=StrTodate(inttostr(GetDateElement(1))+'/'+
                          inttostr(GetDateElement(2))+'/'+TheText);
       for counter:=0 to FSelDates.Count-1 do
          if ((FSelDates[counter]<>'')and
              (strtodate(FSelDates[counter])=DumDate)) then begin
             Canvas.Font.color:=clBlue;
             break;
            end;
    end;
    if ARow=0 then Canvas.Brush.color:=clLtGray
    else if ARow=1 then Canvas.Brush.color:=clBtnFace
    else Canvas.Brush.color:=clwhite;
    if gdSelected in AState then begin
       Canvas.Brush.color:=clHighlight;
       Canvas.Font.color:=clHighlightText;
    end;
    FillRect(DRect);
    TextRect(DRect, Left + (Right - Left - TextWidth(TheText)) div 2,
      Top + (Bottom - Top - TextHeight(TheText)) div 2, TheText);
  end;
end;

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

function TMyCalendar.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 TMyCalendar.SeTCalendarDate(Value: TDateTime);
var
  AYear, AMonth, ADay: Word;
  NYear, NMonth, NDay: Word;
begin
  DecodeDate(Value, NYear, NMonth, NDay);
  FDate := Value;
  UpdateCalendar;
  Change;
  DecodeDate(FDate, AYear, AMonth, ADay);
  if ADay<>NDay then DayChange;
//  DayChange;
end;

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

function TMyCalendar.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 TMyCalendar.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;
    if index=3 then DayChange;
  end;
end;

procedure TMyCalendar.SetShortDateName(Value: Boolean);
begin
   FShortDateName := Value;
   UpdateCalendar;
end;

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

procedure TMyCalendar.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 TMyCalendar.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 TMyCalendar.PrevMonth;
begin
  ChangeMonth(-1);
end;

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

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

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

procedure TMyCalendar.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 + 2,
      False, False);
    Invalidate;
  finally
    FUpdating := False;
  end;
end;

procedure TMyCalendar.WMSize(var Message: TWMSize);
var
  GridLines: Integer;
begin
  GridLines := 6 * GridLineWidth;
  DefaultColWidth := (Message.Width - GridLines) div 7;
  DefaultRowHeight := (Message.Height - GridLines ) div 8;
end;

procedure TMyCalendar.SetSelDates(Value:TStringList);
var i:integer;
begin
  for i:=0 to value.count-1 do begin
     try
        if trim(Value[i])<>'' then strtodatetime(value[i]);
     except
        Showmessage('²Ä'+trim(inttostr(i+1))+'¶µ('+value[i]+')¤é´Á®æ¦¡¤£¥¿½T !');
        value[i]:='';
     end;
  end;
  FSelDates.Assign(Value);
  invalidate;
end;

procedure TMyCalendar.Invalidate;
begin
  FPYBtn.Font.Size:=Font.Size;
  FPMBtn.Font.Size:=Font.Size;
  FNYBtn.Font.Size:=Font.Size;
  FNMBtn.Font.Size:=Font.Size;
  FPYBtn.top:=0;FPYBtn.Height:=RowHeights[0]+GridLineWidth;
  FPMBtn.top:=0;FPMBtn.Height:=RowHeights[0]+GridLineWidth;
  FNYBtn.top:=0;FNYBtn.Height:=RowHeights[0]+GridLineWidth;
  FNMBtn.top:=0;FNMBtn.Height:=RowHeights[0]+GridLineWidth;

  FPYBtn.left:=0;FPYBtn.width:=ColWidths[0]+GridLineWidth;
  FPMBtn.left:=ColWidths[0]+GridLineWidth;FPMBtn.width:=ColWidths[0]+GridLineWidth;
  FNYBtn.left:=6*(ColWidths[0]+GridLineWidth);FNYBtn.width:=ColWidths[0]+GridLineWidth;
  FNMBtn.left:=5*(ColWidths[0]+GridLineWidth);FNMBtn.width:=ColWidths[0]+GridLineWidth;
  inherited Invalidate;
end;
{
procedure TMyCalendar.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var w:Integer;
begin
   if ((button=mbleft)and(y<rowheights[0])) then begin
       w:=colwidths[0]+GridLineWidth;
       if x<w then PrevYear
       else if (x<2*w) then PrevMonth
       else if ((x>5*W)and(x<6*W)) then NextMonth
       else if ((x>6*W)and(x<7*W)) then NextYear;
   end;
   inherited MouseDown(Button,shift,x,y);
end;
}
procedure TMyCalendar.MouseDownPY(Sender: TObject;Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
   if button=mbleft then PrevYear;
end;
procedure TMyCalendar.MouseDownPM(Sender: TObject;Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
   if button=mbleft then PrevMonth;
end;
procedure TMyCalendar.MouseDownNY(Sender: TObject;Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
   if button=mbleft then NextYear;
end;
procedure TMyCalendar.MouseDownNM(Sender: TObject;Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
   if button=mbleft then NextMonth;
end;

end.