home *** CD-ROM | disk | FTP | other *** search
/ PC Format Collection 48 / SENT14D.ISO / tech / delphi / disk15 / sampsrc.pak / CALENDAR.PAS next >
Encoding:
Pascal/Delphi Source File  |  1995-08-24  |  7.9 KB  |  283 lines
  1. unit Calendar;
  2.  
  3. interface
  4.  
  5. uses Classes, Controls, Messages, WinTypes, Forms, Graphics, WinProcs, StdCtrls,
  6.   Grids, SysUtils;
  7.  
  8. type
  9.   TDayOfWeek = 0..6;
  10.  
  11.   TCalendar = class(TCustomGrid)
  12.   private
  13.     FDate: TDateTime;
  14.     FMonthOffset: Integer;
  15.     FOnChange: TNotifyEvent;
  16.     FReadOnly: Boolean;
  17.     FStartOfWeek: TDayOfWeek;
  18.     FUpdating: Boolean;
  19.     FUseCurrentDate: Boolean;
  20.     function GetCellText(ACol, ARow: Integer): string;
  21.     function GetDateElement(Index: Integer): Integer;
  22.     procedure SetCalendarDate(Value: TDateTime);
  23.     procedure SetDateElement(Index: Integer; Value: Integer);
  24.     procedure SetStartOfWeek(Value: TDayOfWeek);
  25.     function StoreCalendarDate: Boolean;
  26.   protected
  27.     procedure Change; dynamic;
  28.     procedure ChangeMonth(Delta: Integer);
  29.     procedure Click; override;
  30.     function DaysPerMonth(AYear, AMonth: Integer): Integer; virtual;
  31.     function DaysThisMonth: Integer; virtual;
  32.     procedure DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState); override;
  33.     function IsLeapYear(AYear: Integer): Boolean; virtual;
  34.     function SelectCell(ACol, ARow: Longint): Boolean; override;
  35.     procedure WMSize(var Message: TWMSize); message WM_SIZE;
  36.   public
  37.     constructor Create(AOwner: TComponent); override;
  38.     property CalendarDate: TDateTime  read FDate write SetCalendarDate stored StoreCalendarDate;
  39.     property CellText[ACol, ARow: Integer]: string read GetCellText;
  40.     procedure NextMonth;
  41.     procedure NextYear;
  42.     procedure PrevMonth;
  43.     procedure PrevYear;
  44.     procedure UpdateCalendar; virtual;
  45.   published
  46.     property Align;
  47.     property BorderStyle;
  48.     property Color;
  49.     property Ctl3D;
  50.     property Day: Integer index 3  read GetDateElement write SetDateElement stored False;
  51.     property Enabled;
  52.     property Font;
  53.     property GridLineWidth;
  54.     property Month: Integer index 2  read GetDateElement write SetDateElement stored False;
  55.     property ParentColor;
  56.     property ParentFont;
  57.     property ParentShowHint;
  58.     property ReadOnly: Boolean read FReadOnly write FReadOnly default False;
  59.     property ShowHint;
  60.     property StartOfWeek: TDayOfWeek read FStartOfWeek write SetStartOfWeek;
  61.     property TabOrder;
  62.     property TabStop;
  63.     property UseCurrentDate: Boolean read FUseCurrentDate write FUseCurrentDate default True;
  64.     property Visible;
  65.     property Year: Integer index 1  read GetDateElement write SetDateElement stored False;
  66.     property OnClick;
  67.     property OnChange: TNotifyEvent read FOnChange write FOnChange;
  68.     property OnDblClick;
  69.     property OnDragDrop;
  70.     property OnDragOver;
  71.     property OnEndDrag;
  72.     property OnEnter;
  73.     property OnExit;
  74.     property OnKeyDown;
  75.     property OnKeyPress;
  76.     property OnKeyUp;
  77.   end;
  78.  
  79. implementation
  80.  
  81. constructor TCalendar.Create(AOwner: TComponent);
  82. begin
  83.   inherited Create(AOwner);
  84.   { defaults }
  85.   FUseCurrentDate := True;
  86.   FixedCols := 0;
  87.   FixedRows := 1;
  88.   ColCount := 7;
  89.   RowCount := 7;
  90.   ScrollBars := ssNone;
  91.   Options := Options - [goRangeSelect] + [goDrawFocusSelected];
  92.   FDate := Date;
  93.   UpdateCalendar;
  94. end;
  95.  
  96. procedure TCalendar.Change;
  97. begin
  98.   if Assigned(FOnChange) then FOnChange(Self);
  99. end;
  100.  
  101. procedure TCalendar.Click;
  102. var
  103.   TheCellText: string;
  104. begin
  105.   inherited Click;
  106.   TheCellText := CellText[Col, Row];
  107.   if TheCellText <> '' then Day := StrToInt(TheCellText);
  108. end;
  109.  
  110. function TCalendar.IsLeapYear(AYear: Integer): Boolean;
  111. begin
  112.   Result := (AYear mod 4 = 0) and ((AYear mod 100 <> 0) or (AYear mod 400 = 0));
  113. end;
  114.  
  115. function TCalendar.DaysPerMonth(AYear, AMonth: Integer): Integer;
  116. const
  117.   DaysInMonth: array[1..12] of Integer = (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
  118. begin
  119.   Result := DaysInMonth[AMonth];
  120.   if (AMonth = 2) and IsLeapYear(AYear) then Inc(Result); { leap-year Feb is special }
  121. end;
  122.  
  123. function TCalendar.DaysThisMonth: Integer;
  124. begin
  125.   Result := DaysPerMonth(Year, Month);
  126. end;
  127.  
  128. procedure TCalendar.DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState);
  129. var
  130.   TheText: string;
  131. begin
  132.   TheText := CellText[ACol, ARow];
  133.   with ARect, Canvas do
  134.     TextRect(ARect, Left + (Right - Left - TextWidth(TheText)) div 2,
  135.       Top + (Bottom - Top - TextHeight(TheText)) div 2, TheText);
  136. end;
  137.  
  138. function TCalendar.GetCellText(ACol, ARow: Integer): string;
  139. var
  140.   DayNum: Integer;
  141. begin
  142.   if ARow = 0 then  { day names at tops of columns }
  143.     Result := ShortDayNames[(StartOfWeek + ACol) mod 7 + 1]
  144.   else
  145.   begin
  146.     DayNum := FMonthOffset + ACol + (ARow - 1) * 7;
  147.     if (DayNum < 1) or (DayNum > DaysThisMonth) then Result := ''
  148.     else Result := IntToStr(DayNum);
  149.   end;
  150. end;
  151.  
  152. function TCalendar.SelectCell(ACol, ARow: Longint): Boolean;
  153. begin
  154.   if ((not FUpdating) and FReadOnly) or (CellText[ACol, ARow] = '') then
  155.     Result := False
  156.   else Result := inherited SelectCell(ACol, ARow);
  157. end;
  158.  
  159. procedure TCalendar.SetCalendarDate(Value: TDateTime);
  160. begin
  161.   FDate := Value;
  162.   UpdateCalendar;
  163.   Change;
  164. end;
  165.  
  166. function TCalendar.StoreCalendarDate: Boolean;
  167. begin
  168.   Result := not FUseCurrentDate;
  169. end;
  170.  
  171. function TCalendar.GetDateElement(Index: Integer): Integer;
  172. var
  173.   AYear, AMonth, ADay: Word;
  174. begin
  175.   DecodeDate(FDate, AYear, AMonth, ADay);
  176.   case Index of
  177.     1: Result := AYear;
  178.     2: Result := AMonth;
  179.     3: Result := ADay;
  180.     else Result := -1;
  181.   end;
  182. end;
  183.  
  184. procedure TCalendar.SetDateElement(Index: Integer; Value: Integer);
  185. var
  186.   AYear, AMonth, ADay: Word;
  187. begin
  188.   if Value > 0 then
  189.   begin
  190.     DecodeDate(FDate, AYear, AMonth, ADay);
  191.     case Index of
  192.       1: if AYear <> Value then AYear := Value else Exit;
  193.       2: if (Value <= 12) and (Value <> AMonth) then AMonth := Value else Exit;
  194.       3: if (Value <= DaysThisMonth) and (Value <> ADay) then ADay := Value else Exit;
  195.       else Exit;
  196.     end;
  197.     FDate := EncodeDate(AYear, AMonth, ADay);
  198.     FUseCurrentDate := False;
  199.     UpdateCalendar;
  200.     Change;
  201.   end;
  202. end;
  203.  
  204. procedure TCalendar.SetStartOfWeek(Value: TDayOfWeek);
  205. begin
  206.   if Value <> FStartOfWeek then
  207.   begin
  208.     FStartOfWeek := Value;
  209.     UpdateCalendar;
  210.   end;
  211. end;
  212.  
  213. { Given a value of 1 or -1, moves to Next or Prev month accordingly }
  214. procedure TCalendar.ChangeMonth(Delta: Integer);
  215. var
  216.   AYear, AMonth, ADay: Word;
  217.   NewDate: TDateTime;
  218.   CurDay: Integer;
  219. begin
  220.   DecodeDate(FDate, AYear, AMonth, ADay);
  221.   CurDay := ADay;
  222.   if Delta > 0 then ADay := DaysPerMonth(AYear, AMonth)
  223.   else ADay := 1;
  224.   NewDate := EncodeDate(AYear, AMonth, ADay);
  225.   NewDate := NewDate + Delta;
  226.   DecodeDate(NewDate, AYear, AMonth, ADay);
  227.   if DaysPerMonth(AYear, AMonth) > CurDay then ADay := CurDay
  228.   else ADay := DaysPerMonth(AYear, AMonth);
  229.   CalendarDate := EncodeDate(AYear, AMonth, ADay);
  230. end;
  231.  
  232. procedure TCalendar.PrevMonth;
  233. begin
  234.   ChangeMonth(-1);
  235. end;
  236.  
  237. procedure TCalendar.NextMonth;
  238. begin
  239.   ChangeMonth(1);
  240. end;
  241.  
  242. procedure TCalendar.NextYear;
  243. begin
  244.   if IsLeapYear(Year) and (Month = 2) and (Day = 29) then Day := 28;
  245.   Year := Year + 1;
  246. end;
  247.  
  248. procedure TCalendar.PrevYear;
  249. begin
  250.   if IsLeapYear(Year) and (Month = 2) and (Day = 29) then Day := 28;
  251.   Year := Year - 1;
  252. end;
  253.  
  254. procedure TCalendar.UpdateCalendar;
  255. var
  256.   AYear, AMonth, ADay: Word;
  257.   FirstDate: TDateTime;
  258. begin
  259.   FUpdating := True;
  260.   try
  261.     DecodeDate(FDate, AYear, AMonth, ADay);
  262.     FirstDate := EncodeDate(AYear, AMonth, 1);
  263.     FMonthOffset := 2 - ((DayOfWeek(FirstDate) - StartOfWeek + 7) mod 7); { day of week for 1st of month }
  264.     if FMonthOffset = 2 then FMonthOffset := -5;
  265.     MoveColRow((ADay - FMonthOffset) mod 7, (ADay - FMonthOffset) div 7 + 1,
  266.       False, False);
  267.     Invalidate;
  268.   finally
  269.     FUpdating := False;
  270.   end;
  271. end;
  272.  
  273. procedure TCalendar.WMSize(var Message: TWMSize);
  274. var
  275.   GridLines: Integer;
  276. begin
  277.   GridLines := 6 * GridLineWidth;
  278.   DefaultColWidth := (Message.Width - GridLines) div 7;
  279.   DefaultRowHeight := (Message.Height - GridLines) div 7;
  280. end;
  281.  
  282. end.
  283.