1 {
2 *****************************************************************************
3 This file is part of the Lazarus Component Library (LCL)
4
5 See the file COPYING.modifiedLGPL.txt, included in this distribution,
6 for details about the license.
7 *****************************************************************************
8
9 Author: Michael Fuchs
10
11 Abstract:
12 Shows a time input popup for a TTimeEdit
13 }
14
15 unit TimePopup;
16
17 {$mode objfpc}{$H+}
18
19 interface
20
21 uses
22 Classes, SysUtils, DateUtils, FileUtil, LCLType, Forms, Controls,
23 Graphics, Dialogs, Grids, ExtCtrls, Buttons, StdCtrls, ActnList, WSForms;
24
25 type
26 TReturnTimeEvent = procedure (Sender: TObject; const ATime: TDateTime) of object;
27
28 { TTimePopupForm }
29
30 TTimePopupForm = class(TForm)
31 Bevel1: TBevel;
32 MainPanel: TPanel;
33 HoursGrid: TStringGrid;
34 MinutesGrid: TStringGrid;
35 MoreLessBtn: TBitBtn;
36 procedure GridsDblClick(Sender: TObject);
37 procedure GridsKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
38 procedure GridPrepareCanvas(sender: TObject; aCol, aRow: Integer;
39 aState: TGridDrawState);
40 procedure MoreLessBtnClick(Sender: TObject);
41 private
42 FClosed: Boolean;
43 FOnReturnTime: TReturnTimeEvent;
44 FSimpleLayout: Boolean;
45 FPopupOrigin: TPoint;
46 FCaller: TControl;
47 procedure ActivateDoubleBuffered;
48 procedure CalcGridHeights;
GetTimenull49 function GetTime: TDateTime;
50 procedure Initialize(const PopupOrigin: TPoint; ATime: TDateTime);
51 procedure KeepInView(const PopupOrigin: TPoint);
52 procedure ReturnTime;
53 procedure SetLayout(SimpleLayout: Boolean);
54 procedure SetTime(ATime: TDateTime);
55 published
56 procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
57 procedure FormCreate(Sender: TObject);
58 procedure FormDeactivate(Sender: TObject);
59 end;
60
61 procedure ShowTimePopup(const Position: TPoint; ATime: TDateTime; const DoubleBufferedForm: Boolean;
62 const OnReturnTime: TReturnTimeEvent; const OnShowHide: TNotifyEvent = nil;
63 SimpleLayout: Boolean = True; ACaller: TControl = nil);
64
65 implementation
66
67 {$R *.lfm}
68
69 procedure ShowTimePopup(const Position: TPoint; ATime: TDateTime; const DoubleBufferedForm: Boolean;
70 const OnReturnTime: TReturnTimeEvent; const OnShowHide: TNotifyEvent;
71 SimpleLayout: Boolean; ACaller: TControl);
72 var
73 NewForm: TTimePopupForm;
74 P: TPoint;
75 begin
76 NewForm := TTimePopupForm.Create(nil);
77 NewForm.FCaller := ACaller;
78 NewForm.Initialize(Position, ATime);
79 NewForm.FOnReturnTime := OnReturnTime;
80 NewForm.OnShow := OnShowHide;
81 NewForm.OnHide := OnShowHide;
82 if DoubleBufferedForm then
83 NewForm.ActivateDoubleBuffered;
84 NewForm.SetLayout(SimpleLayout);
85 if not SimpleLayout then
86 NewForm.SetTime(ATime); //update the row and col in the grid;
87 NewForm.Show;
88 if Assigned(ACaller) then
89 P := ACaller.ControlToScreen(Point(0, ACaller.Height))
90 else
91 P := Position;
92 NewForm.KeepInView(P);
93 end;
94
95 procedure TTimePopupForm.SetTime(ATime: TDateTime);
96 var
97 Hour, Minute: Integer;
98 begin
99 Hour := HourOf(ATime);
100 Minute := MinuteOf(ATime);
101 HoursGrid.Col := Hour mod 12;
102 HoursGrid.Row := Hour div 12;
103 HoursGrid.TopRow := 0; // Avoid morning hours scrolling out of view if time is > 12:00
104 if FSimpleLayout then
105 begin
106 Minute := Minute - (Minute mod 5);
107 MinutesGrid.Col := (Minute mod 30) div 5;
108 MinutesGrid.Row := Minute div 30;
109 end
110 else
111 begin
112 MinutesGrid.Col := Minute mod 5;
113 MinutesGrid.Row := Minute div 5;
114 end;
115 end;
116
117 procedure TTimePopupForm.FormClose(Sender: TObject; var CloseAction: TCloseAction);
118 begin
119 FClosed := true;
120 Application.RemoveOnDeactivateHandler(@FormDeactivate);
121 CloseAction := caFree;
122 end;
123
124 procedure TTimePopupForm.FormCreate(Sender: TObject);
125 begin
126 FClosed := False;
127 FSimpleLayout := True;
128 Application.AddOnDeactivateHandler(@FormDeactivate);
129 SetLayout(FSimpleLayout);
130 end;
131
132 procedure TTimePopupForm.FormDeactivate(Sender: TObject);
133 begin
134 //Immediately hide the form, otherwise it stays visible while e.g. user is draging
135 //another form (Issue 0028441)
136 Hide;
137 if (not FClosed) then
138 Close;
139 end;
140
141 procedure TTimePopupForm.GridsDblClick(Sender: TObject);
142 begin
143 ReturnTime;
144 end;
145
146 procedure TTimePopupForm.GridsKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
147 var
148 Handled: Boolean;
149 begin
150 if Shift=[] then begin
151 Handled := True;
152 case Key of
153 VK_ESCAPE : Close;
154 VK_RETURN, VK_SPACE: ReturnTime;
155 else
156 Handled := False;
157 end;
158 if Handled then
159 Key := 0;
160 end;
161 end;
162
163 procedure TTimePopupForm.GridPrepareCanvas(sender: TObject;
164 aCol, aRow: Integer; aState: TGridDrawState);
165 var
166 ts: TTextStyle;
167 begin
168 ts := (Sender as TStringGrid).Canvas.TextStyle;
169 ts.Layout := tlCenter;
170 ts.Alignment := taCenter;
171 (Sender as TStringGrid).Canvas.TextStyle := ts;
172 end;
173
174 procedure TTimePopupForm.MoreLessBtnClick(Sender: TObject);
175 var
176 OldMin: Integer;
177 begin
178 if FSimpleLayout then
179 begin
180 OldMin := (MinutesGrid.Row * 30) + (MinutesGrid.Col * 5);
181 if (OldMin < 0) then OldMin := 0;
182 if (OldMin > 59) then OldMin := 59;
183 SetLayout(False);
184
185 MinutesGrid.Col := OldMin mod 5;
186 MinutesGrid.Row := OldMin div 5;
187 MoreLessBtn.Caption := '<<';
188 end
189 else
190 begin
191 OldMin := (MinutesGrid.Row * 5) + (MinutesGrid.Col);
192 if (OldMin < 0) then OldMin := 0;
193 if (OldMin > 59) then OldMin := 59;
194 OldMin := OldMin - (OldMin mod 5);
195 SetLayout(True);
196 MinutesGrid.Col := (OldMin mod 30) div 5;
197 MinutesGrid.Row := OldMin div 30;
198 MoreLessBtn.Caption := '>>';
199 end;
200 end;
201
202 procedure TTimePopupForm.SetLayout(SimpleLayout: Boolean);
203 var
204 r, c: Integer;
205 begin
206 MinutesGrid.BeginUpdate;
207 try
208 if SimpleLayout then
209 begin
210 MoreLessBtn.Caption := '>>';
211 MinutesGrid.RowCount := 2;
212 MinutesGrid.ColCount := 6;
213 for r := 0 to MinutesGrid.RowCount - 1 do
214 for c := 0 to MinutesGrid.ColCount - 1 do
215 begin
216 //debugln(Format('[%.2d,%.2d]: %.2d',[r,c,(r*30) + (c*5)]));
217 MinutesGrid.Cells[c,r] := Format('%s%.2d',[DefaultFormatSettings.TimeSeparator,(r*30) + (c*5)]);
218 end;
219 end
220 else
221 begin
222 MoreLessBtn.Caption := '<<';
223 MinutesGrid.RowCount := 12;
224 MinutesGrid.ColCount := 5;
225 for r := 0 to MinutesGrid.RowCount - 1 do
226 for c := 0 to MinutesGrid.ColCount - 1 do
227 begin
228 //debugln(Format('[%.2d,%.2d]: %.2d',[r,c,(r*5) + (c)]));
229 MinutesGrid.Cells[c,r] := Format('%s%.2d',[DefaultFormatSettings.TimeSeparator,(r*5) + (c)]);
230 end;
231 end;
232 CalcGridHeights;
233 FSimpleLayout := SimpleLayout;
234 KeepInView(FPopupOrigin);
235 finally
236 MinutesGrid.EndUpdate(True);
237 end;
238 end;
239
240 procedure TTimePopupForm.ActivateDoubleBuffered;
241 begin
242 DoubleBuffered := TWSCustomFormClass(WidgetSetClass).GetDefaultDoubleBuffered;
243 end;
244
245 procedure TTimePopupForm.CalcGridHeights;
246 var
247 i, RowHeightsSum: Integer;
248 begin
249 RowHeightsSum := 0;
250 for i := 0 to HoursGrid.RowCount - 1 do
251 RowHeightsSum := RowHeightsSum + HoursGrid.RowHeights[i] + 1;
252 HoursGrid.Constraints.MinHeight := RowHeightsSum;
253 RowHeightsSum := 0;
254 for i := 0 to MinutesGrid.RowCount - 1 do
255 RowHeightsSum := RowHeightsSum + MinutesGrid.RowHeights[i] + 1;
256 MinutesGrid.Constraints.MinHeight := RowHeightsSum;
257 MinutesGrid.Height := RowHeightsSum;
258 end;
259
TTimePopupForm.GetTimenull260 function TTimePopupForm.GetTime: TDateTime;
261 var
262 Hour, Minute: Integer;
263 begin
264 Hour := (HoursGrid.Row * 12) + (HoursGrid.Col);
265 if FSimpleLayout then
266 Minute := (MinutesGrid.Row * 30) + (MinutesGrid.Col * 5)
267 else
268 Minute := (MinutesGrid.Row * 5) + (MinutesGrid.Col);
269 Result := EncodeTime(Hour, Minute, 0, 0);
270 end;
271
272 procedure TTimePopupForm.Initialize(const PopupOrigin: TPoint; ATime: TDateTime);
273 begin
274 FPopupOrigin := PopupOrigin;
275 KeepInView(PopupOrigin);
276 SetTime(ATime);
277 end;
278
279 {
280 Try to put the form on a "nice" place on the screen and make sure the entire form is visible.
281 Caller typically wil be a TTimeEdit
282 - first try to place it right under Caller, if that does not fit
283 - try to fit it just above Caller, if that also does not fit (Top < 0) then
284 - simply set Top to zero (in which case it will partially cover Caller
285 }
286 procedure TTimePopupForm.KeepInView(const PopupOrigin: TPoint);
287 var
288 ABounds: TRect;
289 begin
290 ABounds := Screen.MonitorFromPoint(PopupOrigin).WorkAreaRect; // take care of taskbar
291 if PopupOrigin.X + Width > ABounds.Right then
292 Left := ABounds.Right - Width
293 else if PopupOrigin.X < ABounds.Left then
294 Left := ABounds.Left
295 else
296 Left := PopupOrigin.X;
297 if PopupOrigin.Y + Height > ABounds.Bottom then
298 begin
299 if Assigned(FCaller) then
300 Top := PopupOrigin.Y - FCaller.Height - Height
301 else
302 Top := ABounds.Bottom - Height;
303 end else if PopupOrigin.Y < ABounds.Top then
304 Top := ABounds.Top
305 else
306 Top := PopupOrigin.Y;
307 if Left < ABounds.Left then Left := 0;
308 if Top < ABounds.Top then Top := 0;
309 end;
310
311 procedure TTimePopupForm.ReturnTime;
312 begin
313 if Assigned(FOnReturnTime) then
314 FOnReturnTime(Self, Self.GetTime);
315 if not FClosed then
316 Close;
317 end;
318
319 end.
320