smonthcalendar.pas

AlphaControls是一个Delphi标准控件的集合

unit sMonthCalendar;
{$I sDefs.inc}

interface

uses Windows, Classes, Controls, SysUtils, Graphics, buttons, grids, sCustomButton,
  messages, sUtils, sPanel, sGraphUtils, sConst, StdCtrls, forms, comctrls,
  sMessages, sDateUtils;

type
  TDayOfWeek = 0..6;

  TsMonthCalendar = class;

  TsCalendGrid = class(TDrawGrid)
  private
    FOwner: TsMonthCalendar;
    procedure WMSize(var Message: TWMSize); message WM_SIZE;
    procedure WMEraseBkgnd(var Message: TWMSize); message WM_ERASEBKGND;
  protected
    procedure WndProc(var Message: TMessage); override;
  public
    procedure Click; override;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    procedure KeyPress(var Key: Char); override;
    function SelectCell(ACol, ARow: Longint): Boolean; override;
    procedure DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState); override;
    procedure Paint; override;
    constructor Create(AOwner: TComponent); override;
    procedure MouseToCell(X, Y: Integer; var ACol, ARow: Longint);
    property OnDblClick;
    property GridLineWidth;
    property DefaultColWidth;
    property DefaultRowHeight;
  end;

{ TsMonthCalendar }

  TsMonthCalendar = class(TsCustomPanel)
  private
    FDate: TDateTime;
    FMonthOffset: Integer;
    FOnChange: TNotifyEvent;
    FReadOnly: Boolean;
    FStartOfWeek: TCalDayOfWeek;
    FUpdating: Boolean;
    FUseCurrentDate: Boolean;
    FWeekends: TDaysOfWeek;
    FWeekendColor: TColor;
    function GetCellText(ACol, ARow: Integer): string;
    function GetDateElement(Index: Integer): Integer;
    procedure SetCalendarDate(Value: TDateTime);
    procedure SetDateElement(Index: Integer; Value: Integer);
    procedure SetStartOfWeek(Value: TCalDayOfWeek);
    procedure SetUseCurrentDate(Value: Boolean);
    procedure SetWeekendColor(Value: TColor);
    procedure SetWeekends(Value: TDaysOfWeek);
    function IsWeekend(ACol, ARow: Integer): Boolean;
    procedure CalendarUpdate(DayOnly: Boolean);
    function StoreCalendarDate: Boolean;
    function FirstDay: integer;
    procedure TopPanelDblClick(Sender: TObject);
  protected
    procedure Change; dynamic;
    procedure ChangeMonth(Delta: Integer);
    function DaysThisMonth: Integer;
    procedure PrevMonthBtnClick(Sender: TObject);
    procedure NextMonthBtnClick(Sender: TObject);
    procedure PrevYearBtnClick(Sender: TObject);
    procedure NextYearBtnClick(Sender: TObject);
    procedure WndProc(var Message: TMessage); override;
  public
    FGrid: TsCalendGrid;
    FDragBar : TsDragBar;
    FBtns: array[0..3] of TsTimerSpeedButton;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Invalidate; override;
    procedure NextMonth;
    procedure NextYear;
    procedure PrevMonth;
    procedure PrevYear;
    procedure UpdateCalendar; virtual;
    property CellText[ACol, ARow: Integer]: string read GetCellText;
  published
    property Align;
    property BorderWidth default 0;
    property BevelWidth default 5;
    property CalendarDate: TDateTime read FDate write SetCalendarDate stored StoreCalendarDate;
    property Day: Integer index 3  read GetDateElement write SetDateElement stored False;
    property Month: Integer index 2  read GetDateElement write SetDateElement stored False;
    property ReadOnly: Boolean read FReadOnly write FReadOnly default False;
    property StartOfWeek: TCalDayOfWeek read FStartOfWeek write SetStartOfWeek default dowLocaleDefault;
    property UseCurrentDate: Boolean read FUseCurrentDate write SetUseCurrentDate default True;
    property Width default 178;
    property Height default 139;
    property WeekendColor: TColor read FWeekendColor write SetWeekendColor default clRed;
    property Weekends: TDaysOfWeek read FWeekends write SetWeekends default [dowSunday];
    property Year: Integer index 1  read GetDateElement write SetDateElement stored False;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
  end;

implementation

uses Consts, ExtCtrls, sDefaults, sStyleSimply;

{ TsMonthCalendar }

constructor TsMonthCalendar.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  if (csDesigning in ComponentState) and (sStyle.Background.Gradient.Data = '') then begin
    sStyle.Background.Gradient.Data := GradientTsMonthCalendar;
  end;

  FDragBar := TsDragBar.Create(Self);
  FDragBar.Parent := Self;
  FDragBar.OnDblClick := TopPanelDblClick;

  FGrid := TsCalendGrid.Create(Self);
  FGrid.Parent := Self;
  BorderWidth := 0;
  BevelWidth := 5;
  Caption := ' ';

  FUseCurrentDate := True;
  FStartOfWeek := dowLocaleDefault;
  FWeekends := [dowSunday];
  FWeekendColor := clRed;
  FDate := Date;
  UpdateCalendar;
  Width  := 178;
  Height := 139;

  // Prev year button
  FBtns[0] := TsTimerSpeedButton.Create(Self);
  FBtns[0].Parent := FDragBar;
  FBtns[0].Align := alLeft;
  FBtns[0].Caption := '<';
  FBtns[0].sStyle.SkinSection := 'TSSPEEDBUTTON_SMALL';
  FBtns[0].OnClick := PrevYearBtnClick;

  // Prev month button
  FBtns[1] := TsTimerSpeedButton.Create(Self);
  FBtns[1].Parent := FDragBar;
  FBtns[1].Align := alLeft;
  FBtns[1].sStyle.SkinSection := 'TSSPEEDBUTTON_SMALL';
  FBtns[1].Caption := '<<';
  FBtns[1].OnClick := PrevMonthBtnClick;

  // Next month button
  FBtns[2] := TsTimerSpeedButton.Create(Self);
  FBtns[2].Parent := FDragBar;
  FBtns[2].Align := alRight;
  FBtns[2].sStyle.SkinSection := 'TSSPEEDBUTTON_SMALL';
  FBtns[2].Caption := '>>';
  FBtns[2].OnClick := NextMonthBtnClick;

  // Next year button
  FBtns[3] := TsTimerSpeedButton.Create(Self);
  FBtns[3].Parent := FDragBar;
  FBtns[3].Align := alRight;
  FBtns[3].sStyle.SkinSection := 'TSSPEEDBUTTON_SMALL';
  FBtns[3].Caption := '>';
  FBtns[3].OnClick := NextYearBtnClick;
end;

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

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

function TsMonthCalendar.GetCellText(ACol, ARow: Integer): string;
var
  DayNum: Integer;
begin
  if ARow = 0 then begin
    Result := ShortDayNames[(FirstDay + ACol + 1) mod 7 + 1]
  end
  else begin
    DayNum := FMonthOffset + ACol + (ARow - 1) * 7;
    if (DayNum < 1) or (DayNum > DaysThisMonth)
      then Result := ''
      else Result := IntToStr(DayNum);
  end;
end;

procedure TsMonthCalendar.SetCalendarDate(Value: TDateTime);
begin
  if FDate <> Value then begin
    FDate := Value;
    UpdateCalendar;
    Change;
  end;
end;

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

function TsMonthCalendar.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 TsMonthCalendar.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 begin
        AMonth := Value;
        if ADay > DaysPerMonth(Year, Value) then ADay := DaysPerMonth(Year, Value);
      end
      else Exit;
      3: if (Value <= DaysThisMonth) and (Value <> ADay)
        then ADay := Value
        else Exit;
      else Exit;
    end;
    FDate := EncodeDate(AYear, AMonth, ADay);
    FUseCurrentDate := False;
    CalendarUpdate(Index = 3);
    Change;
  end;
end;

procedure TsMonthCalendar.SetWeekendColor(Value: TColor);
begin
  if Value <> FWeekendColor then begin
    FWeekendColor := Value;
    sStyle.Invalidate;
  end;
end;

procedure TsMonthCalendar.SetWeekends(Value: sConst.TDaysOfWeek);
begin
  if Value <> FWeekends then begin
    FWeekends := Value;
    UpdateCalendar;
  end;
end;

function TsMonthCalendar.IsWeekend(ACol, ARow: Integer): Boolean;
begin
  Result := TCalDayOfWeek((FirstDay + ACol) mod 7) in FWeekends;
end;

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

procedure TsMonthCalendar.SetUseCurrentDate(Value: Boolean);
begin
  if Value <> FUseCurrentDate then begin
    FUseCurrentDate := Value;
    if Value then begin
      FDate := Date;
      UpdateCalendar;
    end;
  end;
end;

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

procedure TsMonthCalendar.NextMonth;