PC Format Collection 48/SENT14D.ISO/tech/delphi/disk11/calendar.pak/CALSAMP.PAS

Pascal/Delphi Source File | 1995-08-24 | 5.9 KB | 245 lines

unit CalSamp;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, Grids, StdCtrls;

type
  TSampleCalendar = class(TCustomGrid)
  private
    { Private declarations }
    FDate: TDateTime;
    FMonthOffset: Integer;
    FOnChange: TNotifyEvent;
    procedure SetCalendarDate(Value: TDateTime);
    function GetDateElement(Index: Integer): Integer;
    procedure SetDateElement(Index: Integer; Value: Integer);
  protected
    { Protected declarations }
    procedure Change; dynamic;
    procedure Click; override;
    function DayNum(ACol, ARow: Integer): Integer;
    procedure DrawCell(ACol, ARow: Longint; ARect: TRect;
      AState: TGridDrawState); override;
    function SelectCell(ACol, ARow: Longint): Boolean; override;
    procedure UpdateCalendar; virtual;
    procedure WMSize(var Message: TWMSize); message WM_SIZE;
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    function DaysThisMonth: Integer;
    function IsLeapYear: Boolean;
    procedure NextMonth;
    procedure NextYear;
    procedure PrevMonth;
    procedure PrevYear;
    property CalendarDate: TDateTime  read FDate write SetCalendarDate;
    property Day: Integer  index 3 read GetDateElement write SetDateElement;
    property Month: Integer  index 2 read GetDateElement write SetDateElement;
    property Year: Integer  index 1 read GetDateElement write SetDateElement;
  published
    { Published declarations }
    property Align;
    property BorderStyle;
    property Color;
    property Ctl3D;
    property Font;
    property GridLineWidth;
    property ParentColor;
    property ParentFont;
    property OnChange: TNotifyEvent  read FOnChange write FOnChange;
    property OnClick;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
  end;

procedure Register;

implementation

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

constructor TSampleCalendar.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ColCount := 7;
  RowCount := 7;
  FixedCols := 0;
  FixedRows := 1;
  ScrollBars := ssNone;
  Options := Options - [goRangeSelect] + [goDrawFocusSelected];
  FDate := Date;
  UpdateCalendar;
end;

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

procedure TSampleCalendar.Click;
var
  TempDay: Integer;
begin
  inherited Click;
  TempDay := DayNum(Col, Row);
  if TempDay <> -1 then Day := TempDay;
end;

function TSampleCalendar.DayNum(ACol, ARow: Integer): Integer;
begin
  Result := FMonthOffset + ACol + (ARow - 1) * 7;
  if (Result < 1) or (Result > DaysThisMonth) then Result := -1;
end;

function TSampleCalendar.DaysThisMonth: Integer;
const
  DaysPerMonth: array[1..12] of Integer =
    (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
begin
  if FDate = 0 then Result := 0
  else
  begin
    Result := DaysPerMonth[Month];
    if (Month = 2) and IsLeapYear then Inc(Result);
  end;
end;

procedure TSampleCalendar.DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState);
var
  TheText: string;
  TempDay: Integer;
begin
  if ARow = 0 then
    TheText := ShortDayNames[ACol + 1]
  else
  begin
    TheText := '';
    TempDay := DayNum(ACol, ARow);
    if TempDay <> -1 then TheText := IntToStr(TempDay);
  end;
  with ARect, Canvas do
    TextRect(ARect, Left + (Right - Left - TextWidth(TheText)) div 2,
      Top + (Bottom - Top - TextHeight(TheText)) div 2, TheText);
end;

function TSampleCalendar.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;

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

procedure TSampleCalendar.NextMonth;
begin
  if Month < 12 then
    Month := succ(Month)
  else
  begin
    Year := Year + 1;
    Month := 1;
  end;
end;

procedure TSampleCalendar.NextYear;
begin
  Year := Year + 1;
end;

procedure TSampleCalendar.PrevMonth;
begin
  if Month > 1 then
    Month := pred(Month)
  else
  begin
    Year := Year - 1;
    Month := 12;
  end;
end;

procedure TSampleCalendar.PrevYear;
begin
  Year := Year - 1;
end;

function TSampleCalendar.SelectCell(ACol, ARow: Longint): Boolean;
begin
  if DayNum(ACol, ARow) = -1 then Result := False
  else Result := inherited SelectCell(ACol, ARow);
end;

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

procedure TSampleCalendar.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: AYear := Value;
      2: AMonth := Value;
      3: ADay := Value;
      else Exit;
    end;
    FDate := EncodeDate(AYear, AMonth, ADay);
    UpdateCalendar;
    Change;
  end;
end;

procedure TSampleCalendar.UpdateCalendar;
var
  AYear, AMonth, ADay: Word;
  FirstDate: TDateTime;
begin
  if FDate <> 0 then
  begin
    DecodeDate(FDate, AYear, AMonth, ADay);
    FirstDate := EncodeDate(AYear, AMonth, 1);
    FMonthOffset := 2 - DayOfWeek(FirstDate);
    Row := (ADay - FMonthOffset) div 7 + 1;
    Col := (ADay - FMonthOffset) mod 7;
  end;
  Refresh;
end;

procedure TSampleCalendar.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.