mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-04-05 11:17:57 +02:00
320 lines
8.9 KiB
ObjectPascal
320 lines
8.9 KiB
ObjectPascal
{
|
|
*****************************************************************************
|
|
This file is part of the Lazarus Component Library (LCL)
|
|
|
|
See the file COPYING.modifiedLGPL.txt, included in this distribution,
|
|
for details about the license.
|
|
*****************************************************************************
|
|
|
|
Author: Michael Fuchs
|
|
|
|
Abstract:
|
|
Shows a time input popup for a TTimeEdit
|
|
}
|
|
|
|
unit TimePopup;
|
|
|
|
{$mode objfpc}{$H+}
|
|
|
|
interface
|
|
|
|
uses
|
|
Classes, SysUtils, DateUtils, FileUtil, LCLType, Forms, Controls,
|
|
Graphics, Dialogs, Grids, ExtCtrls, Buttons, StdCtrls, ActnList, WSForms;
|
|
|
|
type
|
|
TReturnTimeEvent = procedure (Sender: TObject; const ATime: TDateTime) of object;
|
|
|
|
{ TTimePopupForm }
|
|
|
|
TTimePopupForm = class(TForm)
|
|
Bevel1: TBevel;
|
|
MainPanel: TPanel;
|
|
HoursGrid: TStringGrid;
|
|
MinutesGrid: TStringGrid;
|
|
MoreLessBtn: TBitBtn;
|
|
procedure GridsDblClick(Sender: TObject);
|
|
procedure GridsKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
|
|
procedure GridPrepareCanvas(sender: TObject; aCol, aRow: Integer;
|
|
aState: TGridDrawState);
|
|
procedure MoreLessBtnClick(Sender: TObject);
|
|
private
|
|
FClosed: Boolean;
|
|
FOnReturnTime: TReturnTimeEvent;
|
|
FSimpleLayout: Boolean;
|
|
FPopupOrigin: TPoint;
|
|
FCaller: TControl;
|
|
procedure ActivateDoubleBuffered;
|
|
procedure CalcGridHeights;
|
|
function GetTime: TDateTime;
|
|
procedure Initialize(const PopupOrigin: TPoint; ATime: TDateTime);
|
|
procedure KeepInView(const PopupOrigin: TPoint);
|
|
procedure ReturnTime;
|
|
procedure SetLayout(SimpleLayout: Boolean);
|
|
procedure SetTime(ATime: TDateTime);
|
|
published
|
|
procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
|
|
procedure FormCreate(Sender: TObject);
|
|
procedure FormDeactivate(Sender: TObject);
|
|
end;
|
|
|
|
procedure ShowTimePopup(const Position: TPoint; ATime: TDateTime; const DoubleBufferedForm: Boolean;
|
|
const OnReturnTime: TReturnTimeEvent; const OnShowHide: TNotifyEvent = nil;
|
|
SimpleLayout: Boolean = True; ACaller: TControl = nil);
|
|
|
|
implementation
|
|
|
|
{$R *.lfm}
|
|
|
|
procedure ShowTimePopup(const Position: TPoint; ATime: TDateTime; const DoubleBufferedForm: Boolean;
|
|
const OnReturnTime: TReturnTimeEvent; const OnShowHide: TNotifyEvent;
|
|
SimpleLayout: Boolean; ACaller: TControl);
|
|
var
|
|
NewForm: TTimePopupForm;
|
|
P: TPoint;
|
|
begin
|
|
NewForm := TTimePopupForm.Create(nil);
|
|
NewForm.FCaller := ACaller;
|
|
NewForm.Initialize(Position, ATime);
|
|
NewForm.FOnReturnTime := OnReturnTime;
|
|
NewForm.OnShow := OnShowHide;
|
|
NewForm.OnHide := OnShowHide;
|
|
if DoubleBufferedForm then
|
|
NewForm.ActivateDoubleBuffered;
|
|
NewForm.SetLayout(SimpleLayout);
|
|
if not SimpleLayout then
|
|
NewForm.SetTime(ATime); //update the row and col in the grid;
|
|
NewForm.Show;
|
|
if Assigned(ACaller) then
|
|
P := ACaller.ControlToScreen(Point(0, ACaller.Height))
|
|
else
|
|
P := Position;
|
|
NewForm.KeepInView(P);
|
|
end;
|
|
|
|
procedure TTimePopupForm.SetTime(ATime: TDateTime);
|
|
var
|
|
Hour, Minute: Integer;
|
|
begin
|
|
Hour := HourOf(ATime);
|
|
Minute := MinuteOf(ATime);
|
|
HoursGrid.Col := Hour mod 12;
|
|
HoursGrid.Row := Hour div 12;
|
|
HoursGrid.TopRow := 0; // Avoid morning hours scrolling out of view if time is > 12:00
|
|
if FSimpleLayout then
|
|
begin
|
|
Minute := Minute - (Minute mod 5);
|
|
MinutesGrid.Col := (Minute mod 30) div 5;
|
|
MinutesGrid.Row := Minute div 30;
|
|
end
|
|
else
|
|
begin
|
|
MinutesGrid.Col := Minute mod 5;
|
|
MinutesGrid.Row := Minute div 5;
|
|
end;
|
|
end;
|
|
|
|
procedure TTimePopupForm.FormClose(Sender: TObject; var CloseAction: TCloseAction);
|
|
begin
|
|
FClosed := true;
|
|
Application.RemoveOnDeactivateHandler(@FormDeactivate);
|
|
CloseAction := caFree;
|
|
end;
|
|
|
|
procedure TTimePopupForm.FormCreate(Sender: TObject);
|
|
begin
|
|
FClosed := False;
|
|
FSimpleLayout := True;
|
|
Application.AddOnDeactivateHandler(@FormDeactivate);
|
|
SetLayout(FSimpleLayout);
|
|
end;
|
|
|
|
procedure TTimePopupForm.FormDeactivate(Sender: TObject);
|
|
begin
|
|
//Immediately hide the form, otherwise it stays visible while e.g. user is draging
|
|
//another form (Issue 0028441)
|
|
Hide;
|
|
if (not FClosed) then
|
|
Close;
|
|
end;
|
|
|
|
procedure TTimePopupForm.GridsDblClick(Sender: TObject);
|
|
begin
|
|
ReturnTime;
|
|
end;
|
|
|
|
procedure TTimePopupForm.GridsKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
|
|
var
|
|
Handled: Boolean;
|
|
begin
|
|
if Shift=[] then begin
|
|
Handled := True;
|
|
case Key of
|
|
VK_ESCAPE : Close;
|
|
VK_RETURN, VK_SPACE: ReturnTime;
|
|
else
|
|
Handled := False;
|
|
end;
|
|
if Handled then
|
|
Key := 0;
|
|
end;
|
|
end;
|
|
|
|
procedure TTimePopupForm.GridPrepareCanvas(sender: TObject;
|
|
aCol, aRow: Integer; aState: TGridDrawState);
|
|
var
|
|
ts: TTextStyle;
|
|
begin
|
|
ts := (Sender as TStringGrid).Canvas.TextStyle;
|
|
ts.Layout := tlCenter;
|
|
ts.Alignment := taCenter;
|
|
(Sender as TStringGrid).Canvas.TextStyle := ts;
|
|
end;
|
|
|
|
procedure TTimePopupForm.MoreLessBtnClick(Sender: TObject);
|
|
var
|
|
OldMin: Integer;
|
|
begin
|
|
if FSimpleLayout then
|
|
begin
|
|
OldMin := (MinutesGrid.Row * 30) + (MinutesGrid.Col * 5);
|
|
if (OldMin < 0) then OldMin := 0;
|
|
if (OldMin > 59) then OldMin := 59;
|
|
SetLayout(False);
|
|
|
|
MinutesGrid.Col := OldMin mod 5;
|
|
MinutesGrid.Row := OldMin div 5;
|
|
MoreLessBtn.Caption := '<<';
|
|
end
|
|
else
|
|
begin
|
|
OldMin := (MinutesGrid.Row * 5) + (MinutesGrid.Col);
|
|
if (OldMin < 0) then OldMin := 0;
|
|
if (OldMin > 59) then OldMin := 59;
|
|
OldMin := OldMin - (OldMin mod 5);
|
|
SetLayout(True);
|
|
MinutesGrid.Col := (OldMin mod 30) div 5;
|
|
MinutesGrid.Row := OldMin div 30;
|
|
MoreLessBtn.Caption := '>>';
|
|
end;
|
|
end;
|
|
|
|
procedure TTimePopupForm.SetLayout(SimpleLayout: Boolean);
|
|
var
|
|
r, c: Integer;
|
|
begin
|
|
MinutesGrid.BeginUpdate;
|
|
try
|
|
if SimpleLayout then
|
|
begin
|
|
MoreLessBtn.Caption := '>>';
|
|
MinutesGrid.RowCount := 2;
|
|
MinutesGrid.ColCount := 6;
|
|
for r := 0 to MinutesGrid.RowCount - 1 do
|
|
for c := 0 to MinutesGrid.ColCount - 1 do
|
|
begin
|
|
//debugln(Format('[%.2d,%.2d]: %.2d',[r,c,(r*30) + (c*5)]));
|
|
MinutesGrid.Cells[c,r] := Format('%s%.2d',[DefaultFormatSettings.TimeSeparator,(r*30) + (c*5)]);
|
|
end;
|
|
end
|
|
else
|
|
begin
|
|
MoreLessBtn.Caption := '<<';
|
|
MinutesGrid.RowCount := 12;
|
|
MinutesGrid.ColCount := 5;
|
|
for r := 0 to MinutesGrid.RowCount - 1 do
|
|
for c := 0 to MinutesGrid.ColCount - 1 do
|
|
begin
|
|
//debugln(Format('[%.2d,%.2d]: %.2d',[r,c,(r*5) + (c)]));
|
|
MinutesGrid.Cells[c,r] := Format('%s%.2d',[DefaultFormatSettings.TimeSeparator,(r*5) + (c)]);
|
|
end;
|
|
end;
|
|
CalcGridHeights;
|
|
FSimpleLayout := SimpleLayout;
|
|
KeepInView(FPopupOrigin);
|
|
finally
|
|
MinutesGrid.EndUpdate(True);
|
|
end;
|
|
end;
|
|
|
|
procedure TTimePopupForm.ActivateDoubleBuffered;
|
|
begin
|
|
DoubleBuffered := TWSCustomFormClass(WidgetSetClass).GetDefaultDoubleBuffered;
|
|
end;
|
|
|
|
procedure TTimePopupForm.CalcGridHeights;
|
|
var
|
|
i, RowHeightsSum: Integer;
|
|
begin
|
|
RowHeightsSum := 0;
|
|
for i := 0 to HoursGrid.RowCount - 1 do
|
|
RowHeightsSum := RowHeightsSum + HoursGrid.RowHeights[i] + 1;
|
|
HoursGrid.Constraints.MinHeight := RowHeightsSum;
|
|
RowHeightsSum := 0;
|
|
for i := 0 to MinutesGrid.RowCount - 1 do
|
|
RowHeightsSum := RowHeightsSum + MinutesGrid.RowHeights[i] + 1;
|
|
MinutesGrid.Constraints.MinHeight := RowHeightsSum;
|
|
MinutesGrid.Height := RowHeightsSum;
|
|
end;
|
|
|
|
function TTimePopupForm.GetTime: TDateTime;
|
|
var
|
|
Hour, Minute: Integer;
|
|
begin
|
|
Hour := (HoursGrid.Row * 12) + (HoursGrid.Col);
|
|
if FSimpleLayout then
|
|
Minute := (MinutesGrid.Row * 30) + (MinutesGrid.Col * 5)
|
|
else
|
|
Minute := (MinutesGrid.Row * 5) + (MinutesGrid.Col);
|
|
Result := EncodeTime(Hour, Minute, 0, 0);
|
|
end;
|
|
|
|
procedure TTimePopupForm.Initialize(const PopupOrigin: TPoint; ATime: TDateTime);
|
|
begin
|
|
FPopupOrigin := PopupOrigin;
|
|
KeepInView(PopupOrigin);
|
|
SetTime(ATime);
|
|
end;
|
|
|
|
{
|
|
Try to put the form on a "nice" place on the screen and make sure the entire form is visible.
|
|
Caller typically wil be a TTimeEdit
|
|
- first try to place it right under Caller, if that does not fit
|
|
- try to fit it just above Caller, if that also does not fit (Top < 0) then
|
|
- simply set Top to zero (in which case it will partially cover Caller
|
|
}
|
|
procedure TTimePopupForm.KeepInView(const PopupOrigin: TPoint);
|
|
var
|
|
ABounds: TRect;
|
|
begin
|
|
ABounds := Screen.MonitorFromPoint(PopupOrigin).WorkAreaRect; // take care of taskbar
|
|
if PopupOrigin.X + Width > ABounds.Right then
|
|
Left := ABounds.Right - Width
|
|
else if PopupOrigin.X < ABounds.Left then
|
|
Left := ABounds.Left
|
|
else
|
|
Left := PopupOrigin.X;
|
|
if PopupOrigin.Y + Height > ABounds.Bottom then
|
|
begin
|
|
if Assigned(FCaller) then
|
|
Top := PopupOrigin.Y - FCaller.Height - Height
|
|
else
|
|
Top := ABounds.Bottom - Height;
|
|
end else if PopupOrigin.Y < ABounds.Top then
|
|
Top := ABounds.Top
|
|
else
|
|
Top := PopupOrigin.Y;
|
|
if Left < ABounds.Left then Left := 0;
|
|
if Top < ABounds.Top then Top := 0;
|
|
end;
|
|
|
|
procedure TTimePopupForm.ReturnTime;
|
|
begin
|
|
if Assigned(FOnReturnTime) then
|
|
FOnReturnTime(Self, Self.GetTime);
|
|
if not FClosed then
|
|
Close;
|
|
end;
|
|
|
|
end.
|