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