home *** CD-ROM | disk | FTP | other *** search
/ Chip 2001 September / Chip_2001-09_cd1.bin / zkuste / delphi / kolekce / d6 / RX275D6.ZIP / Units / PICKDATE.PAS < prev    next >
Pascal/Delphi Source File  |  2001-06-24  |  32KB  |  1,146 lines
  1. {*******************************************************}
  2. {                                                       }
  3. {         Delphi VCL Extensions (RX)                    }
  4. {                                                       }
  5. {         Copyright (c) 1995, 1996 AO ROSNO             }
  6. {         Copyright (c) 1997, 1998 Master-Bank          }
  7. {                                                       }
  8. {*******************************************************}
  9.  
  10. unit PickDate;
  11.  
  12. {$I RX.INC}
  13. {$S-}
  14.  
  15. interface
  16.  
  17. uses Windows, Classes, Variants, Controls, SysUtils, Graphics, DateUtil;
  18.  
  19. { Calendar dialog }
  20.  
  21. function SelectDate(var Date: TDateTime; const DlgCaption: TCaption;
  22.   AStartOfWeek: TDayOfWeekName; AWeekends: TDaysOfWeek;
  23.   AWeekendColor: TColor; BtnHints: TStrings): Boolean;
  24. function SelectDateStr(var StrDate: string; const DlgCaption: TCaption;
  25.   AStartOfWeek: TDayOfWeekName; AWeekends: TDaysOfWeek;
  26.   AWeekendColor: TColor; BtnHints: TStrings): Boolean;
  27. function PopupDate(var Date: TDateTime; Edit: TWinControl): Boolean;
  28.  
  29. { Popup calendar }
  30.  
  31. function CreatePopupCalendar(AOwner: TComponent
  32.   {$IFDEF RX_D4}; ABiDiMode: TBiDiMode = bdLeftToRight {$ENDIF}): TWinControl;
  33. procedure SetupPopupCalendar(PopupCalendar: TWinControl;
  34.   AStartOfWeek: TDayOfWeekName; AWeekends: TDaysOfWeek;
  35.   AWeekendColor: TColor; BtnHints: TStrings; FourDigitYear: Boolean);
  36.  
  37. const
  38.   PopupCalendarSize: TPoint = (X: 187; Y: 124);
  39.  
  40. implementation
  41.  
  42. uses Messages, Consts, Forms, Buttons, StdCtrls, Grids, ExtCtrls, RXCtrls,
  43.   RXCConst, ToolEdit, VCLUtils, MaxMin, rxStrUtils;
  44.  
  45. {$IFDEF WIN32}
  46.  {$R *.R32}
  47. {$ELSE}
  48.  {$R *.R16}
  49. {$ENDIF}
  50.  
  51. const
  52.   SBtnGlyphs: array[0..3] of PChar = ('PREV2', 'PREV1', 'NEXT1', 'NEXT2');
  53.  
  54. procedure FontSetDefault(AFont: TFont);
  55. {$IFDEF WIN32}
  56. var
  57.   NonClientMetrics: TNonClientMetrics;
  58. {$ENDIF}
  59. begin
  60. {$IFDEF WIN32}
  61.   NonClientMetrics.cbSize := SizeOf(NonClientMetrics);
  62.   if SystemParametersInfo(SPI_GETNONCLIENTMETRICS, 0, @NonClientMetrics, 0) then
  63.     AFont.Handle := CreateFontIndirect(NonClientMetrics.lfMessageFont)
  64.   else
  65. {$ENDIF}
  66.   with AFont do begin
  67.     Color := clWindowText;
  68.     Name := 'MS Sans Serif';
  69.     Size := 8;
  70.     Style := [];
  71.   end;
  72. end;
  73.  
  74. { TRxTimerSpeedButton }
  75.  
  76. type
  77.   TRxTimerSpeedButton = class(TRxSpeedButton)
  78.   public
  79.     constructor Create(AOwner: TComponent); override;
  80.   published
  81.     property AllowTimer default True;
  82.     property Style default bsWin31;
  83.   end;
  84.  
  85. constructor TRxTimerSpeedButton.Create(AOwner: TComponent);
  86. begin
  87.   inherited Create(AOwner);
  88.   Style := bsWin31;
  89.   AllowTimer := True;
  90. {$IFDEF WIN32}
  91.   ControlStyle := ControlStyle + [csReplicatable];
  92. {$ENDIF}
  93. end;
  94.  
  95. { TRxCalendar }
  96.  
  97. { TRxCalendar implementation copied from Borland CALENDAR.PAS sample unit
  98.   and modified }
  99.  
  100. type
  101.   TDayOfWeek = 0..6;
  102.  
  103.   TRxCalendar = class(TCustomGrid)
  104.   private
  105.     FDate: TDateTime;
  106.     FMonthOffset: Integer;
  107.     FOnChange: TNotifyEvent;
  108.     FReadOnly: Boolean;
  109.     FStartOfWeek: TDayOfWeekName;
  110.     FUpdating: Boolean;
  111.     FUseCurrentDate: Boolean;
  112.     FWeekends: TDaysOfWeek;
  113.     FWeekendColor: TColor;
  114.     function GetCellText(ACol, ARow: Integer): string;
  115.     function GetDateElement(Index: Integer): Integer;
  116.     procedure SetCalendarDate(Value: TDateTime);
  117.     procedure SetDateElement(Index: Integer; Value: Integer);
  118.     procedure SetStartOfWeek(Value: TDayOfWeekName);
  119.     procedure SetUseCurrentDate(Value: Boolean);
  120.     procedure SetWeekendColor(Value: TColor);
  121.     procedure SetWeekends(Value: TDaysOfWeek);
  122.     function IsWeekend(ACol, ARow: Integer): Boolean;
  123.     procedure CalendarUpdate(DayOnly: Boolean);
  124.     function StoreCalendarDate: Boolean;
  125.   protected
  126.     procedure CreateParams(var Params: TCreateParams); override;
  127.     procedure Change; dynamic;
  128.     procedure ChangeMonth(Delta: Integer);
  129.     procedure Click; override;
  130.     function DaysThisMonth: Integer;
  131.     procedure DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState); override;
  132.     procedure KeyDown(var Key: Word; Shift: TShiftState); override;
  133.     procedure KeyPress(var Key: Char); override;
  134.     function SelectCell(ACol, ARow: Longint): Boolean; override;
  135.     procedure WMSize(var Message: TWMSize); message WM_SIZE;
  136.   public
  137.     constructor Create(AOwner: TComponent); override;
  138.     procedure NextMonth;
  139.     procedure NextYear;
  140.     procedure PrevMonth;
  141.     procedure PrevYear;
  142.     procedure UpdateCalendar; virtual;
  143.     property CellText[ACol, ARow: Integer]: string read GetCellText;
  144.   published
  145.     property CalendarDate: TDateTime read FDate write SetCalendarDate
  146.       stored StoreCalendarDate;
  147.     property Day: Integer index 3  read GetDateElement write SetDateElement stored False;
  148.     property Month: Integer index 2  read GetDateElement write SetDateElement stored False;
  149.     property ReadOnly: Boolean read FReadOnly write FReadOnly default False;
  150.     property StartOfWeek: TDayOfWeekName read FStartOfWeek write SetStartOfWeek default Mon;
  151.     property UseCurrentDate: Boolean read FUseCurrentDate write SetUseCurrentDate default True;
  152.     property WeekendColor: TColor read FWeekendColor write SetWeekendColor default clRed;
  153.     property Weekends: TDaysOfWeek read FWeekends write SetWeekends default [Sun];
  154.     property Year: Integer index 1  read GetDateElement write SetDateElement stored False;
  155.     property OnChange: TNotifyEvent read FOnChange write FOnChange;
  156.   end;
  157.  
  158. constructor TRxCalendar.Create(AOwner: TComponent);
  159. begin
  160.   inherited Create(AOwner);
  161.   FUseCurrentDate := True;
  162.   FStartOfWeek := Mon;
  163.   FWeekends := [Sun];
  164.   FWeekendColor := clRed;
  165.   FixedCols := 0;
  166.   FixedRows := 1;
  167.   ColCount := 7;
  168.   RowCount := 7;
  169.   ScrollBars := ssNone;
  170.   Options := Options - [goRangeSelect] + [goDrawFocusSelected];
  171.   ControlStyle := ControlStyle + [csFramed];
  172.   FDate := Date;
  173.   UpdateCalendar;
  174. end;
  175.  
  176. procedure TRxCalendar.CreateParams(var Params: TCreateParams);
  177. begin
  178.   inherited CreateParams(Params);
  179.   Params.Style := Params.Style or WS_BORDER;
  180. {$IFDEF WIN32}
  181.   Params.ExStyle := Params.ExStyle and not WS_EX_CLIENTEDGE;
  182. {$ENDIF}
  183. {$IFDEF RX_D4}
  184.   AddBiDiModeExStyle(Params.ExStyle);
  185. {$ENDIF}
  186. end;
  187.  
  188. procedure TRxCalendar.Change;
  189. begin
  190.   if Assigned(FOnChange) then FOnChange(Self);
  191. end;
  192.  
  193. procedure TRxCalendar.Click;
  194. var
  195.   TheCellText: string;
  196. begin
  197.   inherited Click;
  198.   TheCellText := CellText[Col, Row];
  199.   if TheCellText <> '' then Day := StrToInt(TheCellText);
  200. end;
  201.  
  202. function TRxCalendar.DaysThisMonth: Integer;
  203. begin
  204.   Result := DaysPerMonth(Year, Month);
  205. end;
  206.  
  207. procedure TRxCalendar.DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState);
  208. var
  209.   TheText: string;
  210. begin
  211.   TheText := CellText[ACol, ARow];
  212.   with ARect, Canvas do begin
  213.     if IsWeekend(ACol, ARow) and not (gdSelected in AState) then
  214.       Font.Color := WeekendColor;
  215.     TextRect(ARect, Left + (Right - Left - TextWidth(TheText)) div 2,
  216.       Top + (Bottom - Top - TextHeight(TheText)) div 2, TheText);
  217.   end;
  218. end;
  219.  
  220. function TRxCalendar.GetCellText(ACol, ARow: Integer): string;
  221. var
  222.   DayNum: Integer;
  223. begin
  224.   if ARow = 0 then  { day names at tops of columns }
  225.     Result := ShortDayNames[(Ord(StartOfWeek) + ACol) mod 7 + 1]
  226.   else begin
  227.     DayNum := FMonthOffset + ACol + (ARow - 1) * 7;
  228.     if (DayNum < 1) or (DayNum > DaysThisMonth) then Result := ''
  229.     else Result := IntToStr(DayNum);
  230.   end;
  231. end;
  232.  
  233. procedure TRxCalendar.KeyDown(var Key: Word; Shift: TShiftState);
  234. begin
  235.   if Shift = [] then
  236.     case Key of
  237.       VK_LEFT, VK_SUBTRACT:
  238.         begin
  239.           if (Day > 1) then Day := Day - 1
  240.           else CalendarDate := CalendarDate - 1;
  241.           Exit;
  242.         end;
  243.       VK_RIGHT, VK_ADD:
  244.         begin
  245.           if (Day < DaysThisMonth) then Day := Day + 1
  246.           else CalendarDate := CalendarDate + 1;
  247.           Exit;
  248.         end
  249.     end;
  250.   inherited KeyDown(Key, Shift);
  251. end;
  252.  
  253. procedure TRxCalendar.KeyPress(var Key: Char);
  254. begin
  255.   if Key in ['T', 't'] then begin
  256.     CalendarDate := Trunc(Now);
  257.     Key := #0;
  258.   end;
  259.   inherited KeyPress(Key);
  260. end;
  261.  
  262. function TRxCalendar.SelectCell(ACol, ARow: Longint): Boolean;
  263. begin
  264.   if ((not FUpdating) and FReadOnly) or (CellText[ACol, ARow] = '') then
  265.     Result := False
  266.   else Result := inherited SelectCell(ACol, ARow);
  267. end;
  268.  
  269. procedure TRxCalendar.SetCalendarDate(Value: TDateTime);
  270. begin
  271.   if FDate <> Value then begin
  272.     FDate := Value;
  273.     UpdateCalendar;
  274.     Change;
  275.   end;
  276. end;
  277.  
  278. function TRxCalendar.StoreCalendarDate: Boolean;
  279. begin
  280.   Result := not FUseCurrentDate;
  281. end;
  282.  
  283. function TRxCalendar.GetDateElement(Index: Integer): Integer;
  284. var
  285.   AYear, AMonth, ADay: Word;
  286. begin
  287.   DecodeDate(FDate, AYear, AMonth, ADay);
  288.   case Index of
  289.     1: Result := AYear;
  290.     2: Result := AMonth;
  291.     3: Result := ADay;
  292.     else Result := -1;
  293.   end;
  294. end;
  295.  
  296. procedure TRxCalendar.SetDateElement(Index: Integer; Value: Integer);
  297. var
  298.   AYear, AMonth, ADay: Word;
  299. begin
  300.   if Value > 0 then begin
  301.     DecodeDate(FDate, AYear, AMonth, ADay);
  302.     case Index of
  303.       1: if AYear <> Value then AYear := Value else Exit;
  304.       2: if (Value <= 12) and (Value <> AMonth) then begin
  305.            AMonth := Value;
  306.            if ADay > DaysPerMonth(Year, Value) then
  307.              ADay := DaysPerMonth(Year, Value);
  308.          end else Exit;
  309.       3: if (Value <= DaysThisMonth) and (Value <> ADay) then
  310.            ADay := Value
  311.          else Exit;
  312.       else Exit;
  313.     end;
  314.     FDate := EncodeDate(AYear, AMonth, ADay);
  315.     FUseCurrentDate := False;
  316.     CalendarUpdate(Index = 3);
  317.     Change;
  318.   end;
  319. end;
  320.  
  321. procedure TRxCalendar.SetWeekendColor(Value: TColor);
  322. begin
  323.   if Value <> FWeekendColor then begin
  324.     FWeekendColor := Value;
  325.     Invalidate;
  326.   end;
  327. end;
  328.  
  329. procedure TRxCalendar.SetWeekends(Value: TDaysOfWeek);
  330. begin
  331.   if Value <> FWeekends then begin
  332.     FWeekends := Value;
  333.     UpdateCalendar;
  334.   end;
  335. end;
  336.  
  337. function TRxCalendar.IsWeekend(ACol, ARow: Integer): Boolean;
  338. begin
  339.   Result := TDayOfWeekName((Integer(StartOfWeek) + ACol) mod 7) in FWeekends;
  340. end;
  341.  
  342. procedure TRxCalendar.SetStartOfWeek(Value: TDayOfWeekName);
  343. begin
  344.   if Value <> FStartOfWeek then begin
  345.     FStartOfWeek := Value;
  346.     UpdateCalendar;
  347.   end;
  348. end;
  349.  
  350. procedure TRxCalendar.SetUseCurrentDate(Value: Boolean);
  351. begin
  352.   if Value <> FUseCurrentDate then begin
  353.     FUseCurrentDate := Value;
  354.     if Value then begin
  355.       FDate := Date; { use the current date, then }
  356.       UpdateCalendar;
  357.     end;
  358.   end;
  359. end;
  360.  
  361. { Given a value of 1 or -1, moves to Next or Prev month accordingly }
  362. procedure TRxCalendar.ChangeMonth(Delta: Integer);
  363. var
  364.   AYear, AMonth, ADay: Word;
  365.   NewDate: TDateTime;
  366.   CurDay: Integer;
  367. begin
  368.   DecodeDate(FDate, AYear, AMonth, ADay);
  369.   CurDay := ADay;
  370.   if Delta > 0 then ADay := DaysPerMonth(AYear, AMonth)
  371.   else ADay := 1;
  372.   NewDate := EncodeDate(AYear, AMonth, ADay);
  373.   NewDate := NewDate + Delta;
  374.   DecodeDate(NewDate, AYear, AMonth, ADay);
  375.   if DaysPerMonth(AYear, AMonth) > CurDay then ADay := CurDay
  376.   else ADay := DaysPerMonth(AYear, AMonth);
  377.   CalendarDate := EncodeDate(AYear, AMonth, ADay);
  378. end;
  379.  
  380. procedure TRxCalendar.PrevMonth;
  381. begin
  382.   ChangeMonth(-1);
  383. end;
  384.  
  385. procedure TRxCalendar.NextMonth;
  386. begin
  387.   ChangeMonth(1);
  388. end;
  389.  
  390. procedure TRxCalendar.NextYear;
  391. begin
  392.   if IsLeapYear(Year) and (Month = 2) and (Day = 29) then Day := 28;
  393.   Year := Year + 1;
  394. end;
  395.  
  396. procedure TRxCalendar.PrevYear;
  397. begin
  398.   if IsLeapYear(Year) and (Month = 2) and (Day = 29) then Day := 28;
  399.   Year := Year - 1;
  400. end;
  401.  
  402. procedure TRxCalendar.CalendarUpdate(DayOnly: Boolean);
  403. var
  404.   AYear, AMonth, ADay: Word;
  405.   FirstDate: TDateTime;
  406. begin
  407.   FUpdating := True;
  408.   try
  409.     DecodeDate(FDate, AYear, AMonth, ADay);
  410.     FirstDate := EncodeDate(AYear, AMonth, 1);
  411.     FMonthOffset := 2 - ((DayOfWeek(FirstDate) - Ord(StartOfWeek) + 7) mod 7);
  412.       { day of week for 1st of month }
  413.     if FMonthOffset = 2 then FMonthOffset := -5;
  414.     MoveColRow((ADay - FMonthOffset) mod 7, (ADay - FMonthOffset) div 7 + 1,
  415.       False, False);
  416.     if DayOnly then Update else Invalidate;
  417.   finally
  418.     FUpdating := False;
  419.   end;
  420. end;
  421.  
  422. procedure TRxCalendar.UpdateCalendar;
  423. begin
  424.   CalendarUpdate(False);
  425. end;
  426.  
  427. procedure TRxCalendar.WMSize(var Message: TWMSize);
  428. var
  429.   GridLinesH, GridLinesW: Integer;
  430. begin
  431.   GridLinesH := 6 * GridLineWidth;
  432.   if (goVertLine in Options) or (goFixedVertLine in Options) then
  433.     GridLinesW := 6 * GridLineWidth
  434.   else GridLinesW := 0;
  435.   DefaultColWidth := (Message.Width - GridLinesW) div 7;
  436.   DefaultRowHeight := (Message.Height - GridLinesH) div 7;
  437. end;
  438.  
  439. { TLocCalendar }
  440.  
  441. type
  442.   TLocCalendar = class(TRxCalendar)
  443.   private
  444.     procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
  445.     procedure CMParentColorChanged(var Message: TMessage); message CM_PARENTCOLORCHANGED;
  446.   protected
  447.     procedure CreateParams(var Params: TCreateParams); override;
  448.     procedure DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState); override;
  449.   public
  450.     constructor Create(AOwner: TComponent); override;
  451.     procedure MouseToCell(X, Y: Integer; var ACol, ARow: Longint);
  452.     property GridLineWidth;
  453.     property DefaultColWidth;
  454.     property DefaultRowHeight;
  455.   end;
  456.  
  457. constructor TLocCalendar.Create(AOwner: TComponent);
  458. begin
  459.   inherited Create(AOwner);
  460.   ControlStyle := [csCaptureMouse, csClickEvents, csDoubleClicks];
  461. {$IFDEF WIN32}
  462.   ControlStyle := ControlStyle + [csReplicatable];
  463. {$ENDIF}
  464.   Ctl3D := False;
  465.   Enabled := False;
  466.   BorderStyle := bsNone;
  467.   ParentColor := True;
  468.   CalendarDate := Trunc(Now);
  469.   UseCurrentDate := False;
  470.   FixedColor := Self.Color;
  471.   Options := [goFixedHorzLine];
  472.   TabStop := False;
  473. end;
  474.  
  475. procedure TLocCalendar.CMParentColorChanged(var Message: TMessage);
  476. begin
  477.   inherited;
  478.   if ParentColor then FixedColor := Self.Color;
  479. end;
  480.  
  481. procedure TLocCalendar.CMEnabledChanged(var Message: TMessage);
  482. begin
  483.   if HandleAllocated and not (csDesigning in ComponentState) then
  484.     EnableWindow(Handle, True);
  485. end;
  486.  
  487. procedure TLocCalendar.CreateParams(var Params: TCreateParams);
  488. begin
  489.   inherited CreateParams(Params);
  490.   with Params do
  491.     Style := Style and not (WS_BORDER or WS_TABSTOP or WS_DISABLED);
  492. end;
  493.  
  494. procedure TLocCalendar.MouseToCell(X, Y: Integer; var ACol, ARow: Longint);
  495. var
  496.   Coord: TGridCoord;
  497. begin
  498.   Coord := MouseCoord(X, Y);
  499.   ACol := Coord.X;
  500.   ARow := Coord.Y;
  501. end;
  502.  
  503. procedure TLocCalendar.DrawCell(ACol, ARow: Longint; ARect: TRect;
  504.   AState: TGridDrawState);
  505. var
  506.   D, M, Y: Word;
  507. begin
  508.   inherited DrawCell(ACol, ARow, ARect, AState);
  509.   DecodeDate(CalendarDate, Y, M, D);
  510.   D := StrToIntDef(CellText[ACol, ARow], 0);
  511.   if (D > 0) and (D <= DaysPerMonth(Y, M)) then begin
  512.     if (EncodeDate(Y, M, D) = SysUtils.Date) then
  513.       Frame3D(Canvas, ARect, clBtnShadow, clBtnHighlight, 1);
  514.   end;
  515. end;
  516.  
  517. { TPopupCalendar }
  518.  
  519. type
  520.   TPopupCalendar = class(TPopupWindow)
  521.   private
  522.     FCalendar: TRxCalendar;
  523.     FTitleLabel: TLabel;
  524.     FFourDigitYear: Boolean;
  525.     FBtns: array[0..3] of TRxSpeedButton;
  526.     procedure CalendarMouseUp(Sender: TObject; Button: TMouseButton;
  527.       Shift: TShiftState; X, Y: Integer);
  528.     procedure PrevMonthBtnClick(Sender: TObject);
  529.     procedure NextMonthBtnClick(Sender: TObject);
  530.     procedure PrevYearBtnClick(Sender: TObject);
  531.     procedure NextYearBtnClick(Sender: TObject);
  532.     procedure CalendarChange(Sender: TObject);
  533.     procedure TopPanelDblClick(Sender: TObject);
  534.   protected
  535.     procedure KeyDown(var Key: Word; Shift: TShiftState); override;
  536.     procedure KeyPress(var Key: Char); override;
  537. {$IFDEF WIN32}
  538.     function GetValue: Variant; override;
  539.     procedure SetValue(const Value: Variant); override;
  540. {$ELSE}
  541.     function GetValue: string; override;
  542.     procedure SetValue(const Value: string); override;
  543. {$ENDIF}
  544.   public
  545.     constructor Create(AOwner: TComponent); override;
  546.   end;
  547.  
  548. function CreatePopupCalendar(AOwner: TComponent
  549.   {$IFDEF RX_D4}; ABiDiMode: TBiDiMode = bdLeftToRight {$ENDIF}): TWinControl;
  550. begin
  551.   Result := TPopupCalendar.Create(AOwner);
  552.   if (AOwner <> nil) and not (csDesigning in AOwner.ComponentState) and
  553.     (Screen.PixelsPerInch <> 96) then
  554.   begin { scale to screen res }
  555.     Result.ScaleBy(Screen.PixelsPerInch, 96);
  556.     { The ScaleBy method does not scale the font well, so set the
  557.       font back to the original info. }
  558.     TPopupCalendar(Result).FCalendar.ParentFont := True;
  559.     FontSetDefault(TPopupCalendar(Result).Font);
  560. {$IFDEF RX_D4}
  561.     Result.BiDiMode := ABiDiMode;
  562. {$ENDIF}
  563.   end;
  564. end;
  565.  
  566. procedure SetupPopupCalendar(PopupCalendar: TWinControl;
  567.   AStartOfWeek: TDayOfWeekName; AWeekends: TDaysOfWeek;
  568.   AWeekendColor: TColor; BtnHints: TStrings; FourDigitYear: Boolean);
  569. var
  570.   I: Integer;
  571. begin
  572.   if (PopupCalendar = nil) or not (PopupCalendar is TPopupCalendar) then
  573.     Exit;
  574.   TPopupCalendar(PopupCalendar).FFourDigitYear := FourDigitYear;
  575.   if TPopupCalendar(PopupCalendar).FCalendar <> nil then begin
  576.     with TPopupCalendar(PopupCalendar).FCalendar do begin
  577.       StartOfWeek := AStartOfWeek;
  578.       WeekendColor := AWeekendColor;
  579.       Weekends := AWeekends;
  580.     end;
  581.     if (BtnHints <> nil) then
  582.       for I := 0 to Min(BtnHints.Count - 1, 3) do begin
  583.         if BtnHints[I] <> '' then
  584.           TPopupCalendar(PopupCalendar).FBtns[I].Hint := BtnHints[I];
  585.       end;
  586.   end;
  587. end;
  588.  
  589. constructor TPopupCalendar.Create(AOwner: TComponent);
  590. const
  591.   BtnSide = 14;
  592. var
  593.   Control, BackPanel: TWinControl;
  594. begin
  595.   inherited Create(AOwner);
  596.   FFourDigitYear := FourDigitYear;
  597.   Height := Max(PopupCalendarSize.Y, 120);
  598.   Width := Max(PopupCalendarSize.X, 180);
  599.   Color := clBtnFace;
  600.   FontSetDefault(Font);
  601.   if AOwner is TControl then ShowHint := TControl(AOwner).ShowHint
  602.   else ShowHint := True;
  603.   if (csDesigning in ComponentState) then Exit;
  604.  
  605.   BackPanel := TPanel.Create(Self);
  606.   with BackPanel as TPanel do begin
  607.     Parent := Self;
  608.     Align := alClient;
  609.     ParentColor := True;
  610. {$IFDEF WIN32}
  611.     ControlStyle := ControlStyle + [csReplicatable];
  612. {$ENDIF}
  613.   end;
  614.  
  615.   Control := TPanel.Create(Self);
  616.   with Control as TPanel do begin
  617.     Parent := BackPanel;
  618.     Align := alTop;
  619.     Width := Self.Width - 4;
  620.     Height := 18;
  621.     BevelOuter := bvNone;
  622.     ParentColor := True;
  623. {$IFDEF WIN32}
  624.     ControlStyle := ControlStyle + [csReplicatable];
  625. {$ENDIF}
  626.   end;
  627.  
  628.   FCalendar := TLocCalendar.Create(Self);
  629.   with TLocCalendar(FCalendar) do begin
  630.     Parent := BackPanel;
  631.     Align := alClient;
  632.     OnChange := CalendarChange;
  633.     OnMouseUp := CalendarMouseUp;
  634.   end;
  635.  
  636.   FBtns[0] := TRxTimerSpeedButton.Create(Self);
  637.   with FBtns[0] do begin
  638.     Parent := Control;
  639.     SetBounds(-1, -1, BtnSide, BtnSide);
  640.     Glyph.Handle := LoadBitmap(hInstance, SBtnGlyphs[0]);
  641.     OnClick := PrevYearBtnClick;
  642.     Hint := LoadStr(SPrevYear);
  643.   end;
  644.  
  645.   FBtns[1] := TRxTimerSpeedButton.Create(Self);
  646.   with FBtns[1] do begin
  647.     Parent := Control;
  648.     SetBounds(BtnSide - 2, -1, BtnSide, BtnSide);
  649.     Glyph.Handle := LoadBitmap(hInstance, SBtnGlyphs[1]);
  650.     OnClick := PrevMonthBtnClick;
  651.     Hint := LoadStr(SPrevMonth);
  652.   end;
  653.  
  654.   FTitleLabel := TLabel.Create(Self);
  655.   with FTitleLabel do begin
  656.     Parent := Control;
  657.     AutoSize := False;
  658.     Alignment := taCenter;
  659.     SetBounds(BtnSide * 2 + 1, 1, Control.Width - 4 * BtnSide - 2, 14);
  660.     Transparent := True;
  661.     OnDblClick := TopPanelDblClick;
  662. {$IFDEF WIN32}
  663.     ControlStyle := ControlStyle + [csReplicatable];
  664. {$ENDIF}
  665.   end;
  666.  
  667.   FBtns[2] := TRxTimerSpeedButton.Create(Self);
  668.   with FBtns[2] do begin
  669.     Parent := Control;
  670.     SetBounds(Control.Width - 2 * BtnSide + 2, -1, BtnSide, BtnSide);
  671.     Glyph.Handle := LoadBitmap(hInstance, SBtnGlyphs[2]);
  672.     OnClick := NextMonthBtnClick;
  673.     Hint := LoadStr(SNextMonth);
  674.   end;
  675.  
  676.   FBtns[3] := TRxTimerSpeedButton.Create(Self);
  677.   with FBtns[3] do begin
  678.     Parent := Control;
  679.     SetBounds(Control.Width - BtnSide + 1, -1, BtnSide, BtnSide);
  680.     Glyph.Handle := LoadBitmap(hInstance, SBtnGlyphs[3]);
  681.     OnClick := NextYearBtnClick;
  682.     Hint := LoadStr(SNextYear);
  683.   end;
  684. end;
  685.  
  686. procedure TPopupCalendar.CalendarMouseUp(Sender: TObject; Button: TMouseButton;
  687.   Shift: TShiftState; X, Y: Integer);
  688. var
  689.   Col, Row: Longint;
  690. begin
  691.   if (Button = mbLeft) and (Shift = []) then begin
  692.     TLocCalendar(FCalendar).MouseToCell(X, Y, Col, Row);
  693.     if (Row > 0) and (FCalendar.CellText[Col, Row] <> '') then
  694.       CloseUp(True);
  695.   end;
  696. end;
  697.  
  698. procedure TPopupCalendar.TopPanelDblClick(Sender: TObject);
  699. begin
  700.   FCalendar.CalendarDate := Trunc(Now);
  701. end;
  702.  
  703. procedure TPopupCalendar.KeyDown(var Key: Word; Shift: TShiftState);
  704. begin
  705.   inherited KeyDown(Key, Shift);
  706.   if FCalendar <> nil then
  707.     case Key of
  708.       VK_NEXT:
  709.         begin
  710.           if ssCtrl in Shift then FCalendar.NextYear
  711.           else FCalendar.NextMonth;
  712.         end;
  713.       VK_PRIOR:
  714.         begin
  715.           if ssCtrl in Shift then FCalendar.PrevYear
  716.           else FCalendar.PrevMonth;
  717.         end;
  718.       else TLocCalendar(FCalendar).KeyDown(Key, Shift);
  719.     end;
  720. end;
  721.  
  722. procedure TPopupCalendar.KeyPress(var Key: Char);
  723. begin
  724.   inherited KeyPress(Key);
  725.   if (FCalendar <> nil) and (Key <> #0) then
  726.     FCalendar.KeyPress(Key);
  727. end;
  728.  
  729. {$IFDEF WIN32}
  730.  
  731. function TPopupCalendar.GetValue: Variant;
  732. begin
  733.   if (csDesigning in ComponentState) then
  734.     Result := VarFromDateTime(SysUtils.Date)
  735.   else
  736.     Result := VarFromDateTime(FCalendar.CalendarDate);
  737. end;
  738.  
  739. procedure TPopupCalendar.SetValue(const Value: Variant);
  740. begin
  741.   if not (csDesigning in ComponentState) then begin
  742.     try
  743.       if (Trim(ReplaceStr(VarToStr(Value), DateSeparator, '')) = '') or
  744.         VarIsNull(Value) or VarIsEmpty(Value) then
  745.         FCalendar.CalendarDate := VarToDateTime(SysUtils.Date)
  746.       else FCalendar.CalendarDate := VarToDateTime(Value);
  747.       CalendarChange(nil);
  748.     except
  749.       FCalendar.CalendarDate := VarToDateTime(SysUtils.Date);
  750.     end;
  751.   end;
  752. end;
  753.  
  754. {$ELSE}
  755.  
  756. function TPopupCalendar.GetValue: string;
  757. begin
  758.   if (csDesigning in ComponentState) then
  759.     Result := FormatDateTime(DefDateFormat(FFourDigitYear), SysUtils.Date)
  760.   else
  761.     Result := FormatDateTime(DefDateFormat(FFourDigitYear), FCalendar.CalendarDate);
  762. end;
  763.  
  764. procedure TPopupCalendar.SetValue(const Value: string);
  765. begin
  766.   if not (csDesigning in ComponentState) then begin
  767.     FCalendar.CalendarDate := StrToDateFmtDef(DefDateFormat(FFourDigitYear),
  768.       Value, SysUtils.Date);
  769.     CalendarChange(nil);
  770.   end;
  771. end;
  772.  
  773. {$ENDIF}
  774.  
  775. procedure TPopupCalendar.PrevYearBtnClick(Sender: TObject);
  776. begin
  777.   FCalendar.PrevYear;
  778. end;
  779.  
  780. procedure TPopupCalendar.NextYearBtnClick(Sender: TObject);
  781. begin
  782.   FCalendar.NextYear;
  783. end;
  784.  
  785. procedure TPopupCalendar.PrevMonthBtnClick(Sender: TObject);
  786. begin
  787.   FCalendar.PrevMonth;
  788. end;
  789.  
  790. procedure TPopupCalendar.NextMonthBtnClick(Sender: TObject);
  791. begin
  792.   FCalendar.NextMonth;
  793. end;
  794.  
  795. procedure TPopupCalendar.CalendarChange(Sender: TObject);
  796. begin
  797.   FTitleLabel.Caption := FormatDateTime('MMMM, YYYY', FCalendar.CalendarDate);
  798. end;
  799.  
  800. { TSelectDateDlg }
  801.  
  802. type
  803.   TSelectDateDlg = class(TForm)
  804.     Calendar: TRxCalendar;
  805.     TitleLabel: TLabel;
  806.     procedure PrevMonthBtnClick(Sender: TObject);
  807.     procedure NextMonthBtnClick(Sender: TObject);
  808.     procedure PrevYearBtnClick(Sender: TObject);
  809.     procedure NextYearBtnClick(Sender: TObject);
  810.     procedure CalendarChange(Sender: TObject);
  811.     procedure CalendarDblClick(Sender: TObject);
  812.     procedure TopPanelDblClick(Sender: TObject);
  813.     procedure FormKeyDown(Sender: TObject; var Key: Word;
  814.       Shift: TShiftState);
  815.   private
  816.     { Private declarations }
  817.     FBtns: array[0..3] of TRxSpeedButton;
  818.     procedure SetDate(Date: TDateTime);
  819.     function GetDate: TDateTime;
  820.   public
  821.     { Public declarations }
  822.     constructor Create(AOwner: TComponent); override;
  823.     property Date: TDateTime read GetDate write SetDate;
  824.   end;
  825.  
  826. constructor TSelectDateDlg.Create(AOwner: TComponent);
  827. var
  828.   Control: TWinControl;
  829. begin
  830. {$IFDEF CBUILDER}
  831.   inherited CreateNew(AOwner, 0);
  832. {$ELSE}
  833.   inherited CreateNew(AOwner);
  834. {$ENDIF}
  835.   Caption := LoadStr(SDateDlgTitle);
  836. {$IFDEF WIN32}
  837.   BorderStyle := bsToolWindow;
  838. {$ELSE}
  839.   BorderStyle := bsDialog;
  840. {$ENDIF}
  841.   BorderIcons := [biSystemMenu];
  842.   ClientHeight := 154;
  843.   ClientWidth := 222;
  844.   FontSetDefault(Font);
  845.   Color := clBtnFace;
  846.   Position := poScreenCenter;
  847.   ShowHint := True;
  848.   KeyPreview := True;
  849.  
  850.   Control := TPanel.Create(Self);
  851.   with Control as TPanel do begin
  852.     Parent := Self;
  853.     SetBounds(0, 0, 222, 22);
  854.     Align := alTop;
  855.     BevelInner := bvLowered;
  856.     ParentColor := True;
  857.     ParentFont := True;
  858.   end;
  859.  
  860.   TitleLabel := TLabel.Create(Self);
  861.   with TitleLabel do begin
  862.     Parent := Control;
  863.     SetBounds(35, 4, 152, 14);
  864.     Alignment := taCenter;
  865.     AutoSize := False;
  866.     Caption := '';
  867.     ParentFont := True;
  868.     Font.Color := clBlue;
  869.     Font.Style := [fsBold];
  870.     Transparent := True;
  871.     OnDblClick := TopPanelDblClick;
  872.   end;
  873.  
  874.   FBtns[0] := TRxTimerSpeedButton.Create(Self);
  875.   with FBtns[0] do begin
  876.     Parent := Control;
  877.     SetBounds(3, 3, 16, 16);
  878.     Glyph.Handle := LoadBitmap(hInstance, SBtnGlyphs[0]);
  879.     OnClick := PrevYearBtnClick;
  880.     Hint := LoadStr(SPrevYear);
  881.   end;
  882.  
  883.   FBtns[1] := TRxTimerSpeedButton.Create(Self);
  884.   with FBtns[1] do begin
  885.     Parent := Control;
  886.     SetBounds(18, 3, 16, 16);
  887.     Glyph.Handle := LoadBitmap(hInstance, SBtnGlyphs[1]);
  888.     OnClick := PrevMonthBtnClick;
  889.     Hint := LoadStr(SPrevMonth);
  890.   end;
  891.  
  892.   FBtns[2] := TRxTimerSpeedButton.Create(Self);
  893.   with FBtns[2] do begin
  894.     Parent := Control;
  895.     SetBounds(188, 3, 16, 16);
  896.     Glyph.Handle := LoadBitmap(hInstance, SBtnGlyphs[2]);
  897.     OnClick := NextMonthBtnClick;
  898.     Hint := LoadStr(SNextMonth);
  899.   end;
  900.  
  901.   FBtns[3] := TRxTimerSpeedButton.Create(Self);
  902.   with FBtns[3] do begin
  903.     Parent := Control;
  904.     SetBounds(203, 3, 16, 16);
  905.     Glyph.Handle := LoadBitmap(hInstance, SBtnGlyphs[3]);
  906.     OnClick := NextYearBtnClick;
  907.     Hint := LoadStr(SNextYear);
  908.   end;
  909.  
  910.   Control := TPanel.Create(Self);
  911.   with Control as TPanel do begin
  912.     Parent := Self;
  913.     SetBounds(0, 133, 222, 21);
  914.     Align := alBottom;
  915.     BevelInner := bvNone;
  916.     BevelOuter := bvNone;
  917.     ParentFont := True;
  918.     ParentColor := True;
  919.   end;
  920.  
  921.   with TButton.Create(Self) do begin
  922.     Parent := Control;
  923.     SetBounds(0, 0, 112, 21);
  924.     Caption := ResStr(SOKButton);
  925.     ModalResult := mrOk;
  926.   end;
  927.  
  928.   with TButton.Create(Self) do begin
  929.     Parent := Control;
  930.     SetBounds(111, 0, 111, 21);
  931.     Caption := ResStr(SCancelButton);
  932.     ModalResult := mrCancel;
  933.     Cancel := True;
  934.   end;
  935.  
  936.   Control := TPanel.Create(Self);
  937.   with Control as TPanel do begin
  938.     Parent := Self;
  939.     SetBounds(0, 22, 222, 111);
  940.     Align := alClient;
  941.     BevelInner := bvLowered;
  942.     ParentFont := True;
  943.     ParentColor := True;
  944.   end;
  945.  
  946.   Calendar := TRxCalendar.Create(Self);
  947.   with Calendar do begin
  948.     Parent := Control;
  949.     Align := alClient;
  950.     ParentFont := True;
  951.     SetBounds(2, 2, 218, 113);
  952.     Color := clWhite;
  953.     TabOrder := 0;
  954.     UseCurrentDate := False;
  955.     OnChange := CalendarChange;
  956.     OnDblClick := CalendarDblClick;
  957.   end;
  958.  
  959.   OnKeyDown := FormKeyDown;
  960.   Calendar.CalendarDate := Trunc(Now);
  961.   ActiveControl := Calendar;
  962. end;
  963.  
  964. procedure TSelectDateDlg.SetDate(Date: TDateTime);
  965. begin
  966.   if Date = NullDate then Date := SysUtils.Date;
  967.   try
  968.     Calendar.CalendarDate := Date;
  969.     CalendarChange(nil);
  970.   except
  971.     Calendar.CalendarDate := SysUtils.Date;
  972.   end;
  973. end;
  974.  
  975. function TSelectDateDlg.GetDate: TDateTime;
  976. begin
  977.   Result := Calendar.CalendarDate;
  978. end;
  979.  
  980. procedure TSelectDateDlg.TopPanelDblClick(Sender: TObject);
  981. begin
  982.   SetDate(Trunc(Now));
  983. end;
  984.  
  985. procedure TSelectDateDlg.PrevYearBtnClick(Sender: TObject);
  986. begin
  987.   Calendar.PrevYear;
  988. end;
  989.  
  990. procedure TSelectDateDlg.NextYearBtnClick(Sender: TObject);
  991. begin
  992.   Calendar.NextYear;
  993. end;
  994.  
  995. procedure TSelectDateDlg.PrevMonthBtnClick(Sender: TObject);
  996. begin
  997.   Calendar.PrevMonth;
  998. end;
  999.  
  1000. procedure TSelectDateDlg.NextMonthBtnClick(Sender: TObject);
  1001. begin
  1002.   Calendar.NextMonth;
  1003. end;
  1004.  
  1005. procedure TSelectDateDlg.CalendarChange(Sender: TObject);
  1006. begin
  1007.   TitleLabel.Caption := FormatDateTime('MMMM, YYYY', Calendar.CalendarDate);
  1008. end;
  1009.  
  1010. procedure TSelectDateDlg.CalendarDblClick(Sender: TObject);
  1011. begin
  1012.   ModalResult := mrOK;
  1013. end;
  1014.  
  1015. procedure TSelectDateDlg.FormKeyDown(Sender: TObject; var Key: Word;
  1016.   Shift: TShiftState);
  1017. begin
  1018.   case Key of
  1019.     VK_RETURN: ModalResult := mrOK;
  1020.     VK_ESCAPE: ModalResult := mrCancel;
  1021.     VK_NEXT:
  1022.       begin
  1023.         if ssCtrl in Shift then Calendar.NextYear
  1024.         else Calendar.NextMonth;
  1025.         TitleLabel.Update;
  1026.       end;
  1027.     VK_PRIOR:
  1028.       begin
  1029.         if ssCtrl in Shift then Calendar.PrevYear
  1030.         else Calendar.PrevMonth;
  1031.         TitleLabel.Update;
  1032.       end;
  1033.     VK_TAB:
  1034.       begin
  1035.         if Shift = [ssShift] then Calendar.PrevMonth
  1036.         else Calendar.NextMonth;
  1037.         TitleLabel.Update;
  1038.       end;
  1039.   end; {case}
  1040. end;
  1041.  
  1042. { SelectDate routines }
  1043.  
  1044. function CreateDateDialog(const DlgCaption: TCaption): TSelectDateDlg;
  1045. begin
  1046.   Result := TSelectDateDlg.Create(Application);
  1047.   try
  1048.     if DlgCaption <> '' then Result.Caption := DlgCaption;
  1049.     if Screen.PixelsPerInch <> 96 then begin { scale to screen res }
  1050.       Result.ScaleBy(Screen.PixelsPerInch, 96);
  1051.       { The ScaleBy method does not scale the font well, so set the
  1052.         font back to the original info. }
  1053.       Result.Calendar.ParentFont := True;
  1054.       FontSetDefault(Result.Font);
  1055.       Result.Left := (Screen.Width div 2) - (Result.Width div 2);
  1056.       Result.Top := (Screen.Height div 2) - (Result.Height div 2);
  1057.     end;
  1058.   except
  1059.     Result.Free;
  1060.     raise;
  1061.   end;
  1062. end;
  1063.  
  1064. function PopupDate(var Date: TDateTime; Edit: TWinControl): Boolean;
  1065. var
  1066.   D: TSelectDateDlg;
  1067.   P: TPoint;
  1068.   W, H, X, Y: Integer;
  1069. begin
  1070.   Result := False;
  1071.   D := CreateDateDialog('');
  1072.   try
  1073.     D.BorderIcons := [];
  1074.     D.HandleNeeded;
  1075.     D.Position := poDesigned;
  1076.     W := D.Width;
  1077.     H := D.Height;
  1078.     P := (Edit.ClientOrigin);
  1079.     Y := P.Y + Edit.Height - 1;
  1080.     if (Y + H) > Screen.Height then Y := P.Y - H + 1;
  1081.     if Y < 0 then Y := P.Y + Edit.Height - 1;
  1082.     X := (P.X + Edit.Width) - W;
  1083.     if X < 0 then X := P.X;
  1084.     D.Left := X;
  1085.     D.Top := Y;
  1086.     D.Date := Date;
  1087.     if D.ShowModal = mrOk then begin
  1088.       Date := D.Date;
  1089.       Result := True;
  1090.     end;
  1091.   finally
  1092.     D.Free;
  1093.   end;
  1094. end;
  1095.  
  1096. function SelectDate(var Date: TDateTime; const DlgCaption: TCaption;
  1097.   AStartOfWeek: TDayOfWeekName; AWeekends: TDaysOfWeek;
  1098.   AWeekendColor: TColor; BtnHints: TStrings): Boolean;
  1099. var
  1100.   D: TSelectDateDlg;
  1101.   I: Integer;
  1102. begin
  1103.   Result := False;
  1104.   D := CreateDateDialog(DlgCaption);
  1105.   try
  1106.     D.Date := Date;
  1107.     with D.Calendar do begin
  1108.       StartOfWeek := AStartOfWeek;
  1109.       Weekends := AWeekends;
  1110.       WeekendColor := AWeekendColor;
  1111.     end;
  1112.     if (BtnHints <> nil) then
  1113.       for I := 0 to Min(BtnHints.Count - 1, 3) do begin
  1114.         if BtnHints[I] <> '' then
  1115.           D.FBtns[I].Hint := BtnHints[I];
  1116.       end;
  1117.     if D.ShowModal = mrOk then begin
  1118.       Date := D.Date;
  1119.       Result := True;
  1120.     end;
  1121.   finally
  1122.     D.Free;
  1123.   end;
  1124. end;
  1125.  
  1126. function SelectDateStr(var StrDate: string; const DlgCaption: TCaption;
  1127.   AStartOfWeek: TDayOfWeekName; AWeekends: TDaysOfWeek;
  1128.   AWeekendColor: TColor; BtnHints: TStrings): Boolean;
  1129. var
  1130.   DateValue: TDateTime;
  1131. begin
  1132.   if StrDate <> '' then begin
  1133.     try
  1134.       DateValue := StrToDateFmt(ShortDateFormat, StrDate);
  1135.     except
  1136.       DateValue := Date;
  1137.     end;
  1138.   end
  1139.   else DateValue := Date;
  1140.   Result := SelectDate(DateValue, DlgCaption, AStartOfWeek, AWeekends,
  1141.     AWeekendColor, BtnHints);
  1142.   if Result then StrDate := FormatDateTime(ShortDateFormat, DateValue);
  1143. end;
  1144.  
  1145. end.
  1146.