mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-04-06 07:58:07 +02:00
lcl: implement window snapping / magnetic borders
This commit is contained in:
Martok
Maxim Ganetsky
parent
737e0875cd
commit
b83838139d
51
lcl/forms.pp
51
lcl/forms.pp
@ -86,6 +86,7 @@ type
|
||||
TIDesigner = class;
|
||||
TMonitor = class;
|
||||
TScrollingWinControl = class;
|
||||
TCustomForm = class;
|
||||
|
||||
{ Hint actions }
|
||||
|
||||
@ -415,6 +416,41 @@ type
|
||||
end;
|
||||
|
||||
|
||||
{ TWindowMagnetOptions }
|
||||
|
||||
TWindowMagnetOptions = class(TPersistent)
|
||||
private
|
||||
FSnapMonitor: boolean;
|
||||
FSnapForms: boolean;
|
||||
FSnapFormTarget: boolean;
|
||||
FDistance: integer;
|
||||
public
|
||||
constructor Create;
|
||||
published
|
||||
property SnapToMonitor: boolean read FSnapMonitor write FSnapMonitor default false;
|
||||
property SnapToForms: boolean read FSnapForms write FSnapForms default false;
|
||||
property SnapFormTarget: boolean read FSnapFormTarget write FSnapFormTarget default true;
|
||||
property Distance: integer read FDistance write FDistance default 10;
|
||||
end;
|
||||
|
||||
{ TWindowMagnetManager }
|
||||
|
||||
TWindowMagnetManager = class
|
||||
private
|
||||
FEnabled: boolean;
|
||||
FActiveForm: TCustomForm;
|
||||
FPreviousSource, FPreviousReturn: TWindowPos;
|
||||
protected
|
||||
function SnapToSides(var x, cx: integer; px, pcx, pxout, pcxout: integer; dist: integer; leftsides, rightsides: TIntegerDynArray): boolean;
|
||||
function SnapToMonitor(Opts: TWindowMagnetOptions; var WindowPos: TWindowPos): boolean;
|
||||
function SnapToForms(Opts: TWindowMagnetOptions; var WindowPos: TWindowPos): boolean;
|
||||
public
|
||||
constructor Create;
|
||||
property Enabled: boolean read FEnabled write FEnabled;
|
||||
function SnapForm(Form: TCustomForm; var WindowPos: TWindowPos): boolean;
|
||||
end;
|
||||
|
||||
|
||||
{ TCustomForm }
|
||||
|
||||
TBorderIcon = ( // Form title bar items
|
||||
@ -530,6 +566,7 @@ type
|
||||
FDelayedEventCtr: Integer;
|
||||
FDelayedOnChangeBounds, FDelayedOnResize: Boolean;
|
||||
FIsFirstOnShow, FIsFirstOnActivate: Boolean;
|
||||
FSnapOptions: TWindowMagnetOptions;
|
||||
function GetClientHandle: HWND;
|
||||
function GetEffectiveShowInTaskBar: TShowInTaskBar;
|
||||
function GetMonitor: TMonitor;
|
||||
@ -568,12 +605,17 @@ type
|
||||
function FindDefaultForActiveControl: TWinControl;
|
||||
procedure UpdateMenu;
|
||||
procedure UpdateShowInTaskBar;
|
||||
function GetScreenSnap: boolean;
|
||||
procedure SetScreenSnap(aValue: boolean);
|
||||
function GetSnapBuffer: integer;
|
||||
procedure SetSnapBuffer(aValue: integer);
|
||||
protected
|
||||
procedure WMActivate(var Message : TLMActivate); message LM_ACTIVATE;
|
||||
procedure WMCloseQuery(var message: TLMessage); message LM_CLOSEQUERY;
|
||||
procedure WMHelp(var Message: TLMHelp); message LM_HELP;
|
||||
procedure WMShowWindow(var message: TLMShowWindow); message LM_SHOWWINDOW;
|
||||
procedure WMSize(var message: TLMSize); message LM_Size;
|
||||
procedure WMWindowPosChanging(var Message: TLMWindowPosChanging); message LM_WINDOWPOSCHANGING;
|
||||
procedure WMWindowPosChanged(var Message: TLMWindowPosChanged); message LM_WINDOWPOSCHANGED;
|
||||
procedure CMBiDiModeChanged(var Message: TLMessage); message CM_BIDIMODECHANGED;
|
||||
procedure CMParentBiDiModeChanged(var Message: TLMessage); message CM_PARENTBIDIMODECHANGED;
|
||||
@ -753,6 +795,9 @@ type
|
||||
property LastActiveControl: TWinControl read FLastActiveControl;
|
||||
property PopupMode: TPopupMode read FPopupMode write SetPopupMode default pmNone;
|
||||
property PopupParent: TCustomForm read FPopupParent write SetPopupParent;
|
||||
property SnapOptions: TWindowMagnetOptions read FSnapOptions;
|
||||
property ScreenSnap: boolean read GetScreenSnap write SetScreenSnap stored false;
|
||||
property SnapBuffer: integer read GetSnapBuffer write SetSnapBuffer stored false;
|
||||
|
||||
property OnActivate: TNotifyEvent read FOnActivate write FOnActivate;
|
||||
property OnClose: TCloseEvent read FOnClose write FOnClose stored IsForm;
|
||||
@ -898,8 +943,11 @@ type
|
||||
property PopupParent;
|
||||
property Position;
|
||||
property SessionProperties;
|
||||
property ScreenSnap;
|
||||
property ShowHint;
|
||||
property ShowInTaskBar;
|
||||
property SnapBuffer;
|
||||
property SnapOptions;
|
||||
property UseDockManager;
|
||||
property LCLVersion: string read FLCLVersion write FLCLVersion stored LCLVersionIsStored;
|
||||
property Scaled;
|
||||
@ -1102,6 +1150,7 @@ type
|
||||
FPixelsPerInch : Integer;
|
||||
FSaveFocusedList: TFPList;
|
||||
FSystemFont: TFont;
|
||||
FMagnetManager: TWindowMagnetManager;
|
||||
procedure DeleteCursor(AIndex: Integer);
|
||||
procedure DestroyCursors;
|
||||
procedure DestroyMonitors;
|
||||
@ -1157,6 +1206,7 @@ type
|
||||
function GetIconFont: TFont; virtual;
|
||||
function GetMenuFont: TFont; virtual;
|
||||
function GetSystemFont: TFont; virtual;
|
||||
property MagnetManager: TWindowMagnetManager read FMagnetManager;
|
||||
public
|
||||
constructor Create(AOwner : TComponent); override;
|
||||
destructor Destroy; override;
|
||||
@ -2323,6 +2373,7 @@ end;
|
||||
{$I application.inc}
|
||||
{$I applicationproperties.inc}
|
||||
{$I hintwindow.inc}
|
||||
{$I windowmagnet.inc}
|
||||
|
||||
|
||||
//==============================================================================
|
||||
|
||||
@ -131,6 +131,7 @@ begin
|
||||
FreeIconHandles;
|
||||
Screen.RemoveForm(Self);
|
||||
FreeThenNil(FActionLists);
|
||||
FreeThenNil(FSnapOptions);
|
||||
for HandlerType:=Low(FFormHandlers) to High(FFormHandlers) do
|
||||
FreeThenNil(FFormHandlers[HandlerType]);
|
||||
//DebugLn('[TCustomForm.Destroy] B ',Name,':',ClassName);
|
||||
@ -2083,6 +2084,7 @@ begin
|
||||
FloatingDockSiteClass := TWinControlClass(ClassType);
|
||||
Screen.AddForm(Self);
|
||||
FAllowDropFiles := False;
|
||||
FSnapOptions:= TWindowMagnetOptions.Create;
|
||||
|
||||
if ParentBiDiMode then
|
||||
BiDiMode := Application.BidiMode;
|
||||
|
||||
@ -71,6 +71,7 @@ begin
|
||||
FDataModuleList := TFPList.Create;
|
||||
FPixelsPerInch := ScreenInfo.PixelsPerInchX;
|
||||
FSaveFocusedList := TFPList.Create;
|
||||
FMagnetManager := TWindowMagnetManager.Create;
|
||||
|
||||
AddDataModule := @DoAddDataModule;
|
||||
RemoveDataModule := @DoRemoveDataModule;
|
||||
@ -102,6 +103,7 @@ begin
|
||||
FreeThenNil(FCustomFormsZOrdered);
|
||||
FreeThenNil(FSaveFocusedList);
|
||||
FreeThenNil(FFonts);
|
||||
FreeThenNil(FMagnetManager);
|
||||
// DestroyCursors; - free on widgetset free
|
||||
FCursorMap.Free;
|
||||
FMonitors.Free;
|
||||
|
||||
229
lcl/include/windowmagnet.inc
Normal file
229
lcl/include/windowmagnet.inc
Normal file
@ -0,0 +1,229 @@
|
||||
{%MainUnit ../forms.pp}
|
||||
|
||||
{ TWindowMagnetManager
|
||||
|
||||
*****************************************************************************
|
||||
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.
|
||||
*****************************************************************************
|
||||
}
|
||||
|
||||
{ TWindowMagnetOptions }
|
||||
|
||||
constructor TWindowMagnetOptions.Create;
|
||||
begin
|
||||
inherited;
|
||||
FSnapMonitor:= false;
|
||||
FSnapForms:= false;
|
||||
FSnapFormTarget:= true;
|
||||
FDistance:= 10;
|
||||
end;
|
||||
|
||||
{ TWindowMagnetManager }
|
||||
|
||||
function PosToRect(wp: TWindowPos): TRect;
|
||||
begin
|
||||
Result.Left:= wp.x;
|
||||
Result.Top:= wp.y;
|
||||
Result.Right:= wp.x + wp.cx;
|
||||
Result.Bottom:= wp.y + wp.cy;
|
||||
end;
|
||||
|
||||
constructor TWindowMagnetManager.Create;
|
||||
begin
|
||||
inherited Create;
|
||||
FEnabled:= true;
|
||||
FActiveForm:= nil;
|
||||
FPreviousSource:= Default(TWindowPos);
|
||||
FPreviousReturn:= Default(TWindowPos);
|
||||
end;
|
||||
|
||||
function TWindowMagnetManager.SnapForm(Form: TCustomForm; var WindowPos: TWindowPos): boolean;
|
||||
var
|
||||
SrcPos: TWindowPos;
|
||||
begin
|
||||
Result:= false;
|
||||
// FIXME: compiler bug? generates nonsensical comps if done in one statement
|
||||
if not FEnabled then Exit;
|
||||
if ((WindowPos.flags and SWP_SHOWWINDOW) > 0) then Exit;
|
||||
if ((WindowPos.flags and SWP_HIDEWINDOW) > 0) then Exit;
|
||||
if (Form.ComponentState * [csDestroying, csDesigning, csLoading] <> []) then Exit;
|
||||
if not (Form.SnapOptions.SnapToMonitor or Form.SnapOptions.SnapToForms) then Exit;
|
||||
|
||||
SrcPos:= WindowPos;
|
||||
if Form <> FActiveForm then begin
|
||||
FActiveForm:= Form;
|
||||
FPreviousSource:= WindowPos;
|
||||
FPreviousReturn:= WindowPos;
|
||||
Exit;
|
||||
end;
|
||||
|
||||
Result:= SnapToMonitor(Form.SnapOptions, WindowPos) or
|
||||
SnapToForms(Form.SnapOptions, WindowPos);
|
||||
|
||||
FPreviousSource:= SrcPos;
|
||||
FPreviousReturn:= WindowPos;
|
||||
end;
|
||||
|
||||
function TWindowMagnetManager.SnapToSides(var x, cx: integer; px, pcx, pxout, pcxout: integer; dist: integer; leftsides, rightsides: TIntegerDynArray): boolean;
|
||||
var
|
||||
Moving, Resizing: Boolean;
|
||||
goal: Integer;
|
||||
begin
|
||||
Result:= False;
|
||||
Moving:= x <> px;
|
||||
Resizing:= cx <> pcx;
|
||||
|
||||
try
|
||||
if Resizing and Moving then begin
|
||||
// Resizing Left Edge
|
||||
for goal in leftsides do begin
|
||||
Result:= Abs(x - goal) < dist;
|
||||
if Result then begin
|
||||
Inc(cx, x - goal);
|
||||
x:= goal;
|
||||
Exit;
|
||||
end;
|
||||
end;
|
||||
end else
|
||||
if Resizing then begin
|
||||
// Resizing Right Edge
|
||||
for goal in rightsides do begin
|
||||
Result:= Abs(x + cx - goal) < dist;
|
||||
if Result then begin
|
||||
cx:= goal - x;
|
||||
Exit;
|
||||
end;
|
||||
end;
|
||||
end else
|
||||
if Moving then begin
|
||||
// Moving Left Edge
|
||||
for goal in leftsides do begin
|
||||
Result:= Abs(x - goal) < dist;
|
||||
if Result then begin
|
||||
x:= goal;
|
||||
Exit;
|
||||
end;
|
||||
end;
|
||||
// Moving Right Edge
|
||||
for goal in rightsides do begin
|
||||
Result:= Abs(x + cx - goal) < dist;
|
||||
if Result then begin
|
||||
x:= goal - cx;
|
||||
Exit;
|
||||
end;
|
||||
end;
|
||||
end else begin
|
||||
// No change on this axis
|
||||
x:= pxout;
|
||||
cx:= pcxout;
|
||||
end;
|
||||
finally
|
||||
Result:= Result and ((x<>pcxout) or (cx<>pcxout));
|
||||
end;
|
||||
end;
|
||||
|
||||
function TWindowMagnetManager.SnapToMonitor(Opts: TWindowMagnetOptions; var WindowPos: TWindowPos): boolean;
|
||||
var
|
||||
Rect, Area: TRect;
|
||||
begin
|
||||
Result:= False;
|
||||
if not Opts.SnapToMonitor then
|
||||
Exit;
|
||||
Rect:= PosToRect(WindowPos);
|
||||
Area:= Screen.MonitorFromRect(Rect).WorkareaRect;
|
||||
{$push}
|
||||
{$BoolEval on} // do not short-circuit, SnapToSides has sideffects that must take place either way
|
||||
Result:= SnapToSides(WindowPos.x, WindowPos.cx, FPreviousSource.x, FPreviousSource.cx, FPreviousReturn.x, FPreviousReturn.cx, Opts.Distance, [Area.Left], [Area.Right]) or
|
||||
SnapToSides(WindowPos.y, WindowPos.cy, FPreviousSource.y, FPreviousSource.cy, FPreviousReturn.y, FPreviousReturn.cy, Opts.Distance, [Area.Top], [Area.Bottom]);
|
||||
{$pop}
|
||||
end;
|
||||
|
||||
function TWindowMagnetManager.SnapToForms(Opts: TWindowMagnetOptions; var WindowPos: TWindowPos): boolean;
|
||||
|
||||
procedure Append(Item: integer; var List: TIntegerDynArray);
|
||||
begin
|
||||
Insert(Item, List, Length(List));
|
||||
end;
|
||||
|
||||
procedure AddGoals(wtop, wbot, otop, obot, oleft, oright, mleft, mright: integer; var snapleft, snapright, snapup, snapdown: TIntegerDynArray);
|
||||
begin
|
||||
// is there any overlap?
|
||||
if (wtop < obot) and (wbot > otop) then begin
|
||||
Append(oleft, snapright);
|
||||
Append(oright, snapleft);
|
||||
if (oleft = mright) or (oright = mleft) then begin
|
||||
// already magnetised on L-R axis, include top-top/bottom-bottom align goals
|
||||
Append(otop, snapup);
|
||||
Append(obot, snapdown);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
var
|
||||
Rect, br, PrevRect: TRect;
|
||||
SnapTo: array[0..3] of TIntegerDynArray; // CSS order: t,r,b,l
|
||||
fi: Integer;
|
||||
frm: TCustomForm;
|
||||
begin
|
||||
Result:= False;
|
||||
if not Opts.SnapToForms then
|
||||
Exit;
|
||||
Rect:= PosToRect(WindowPos);
|
||||
PrevRect:= PosToRect(FPreviousReturn);
|
||||
|
||||
SnapTo[0]:= nil;
|
||||
SnapTo[1]:= nil;
|
||||
SnapTo[2]:= nil;
|
||||
SnapTo[3]:= nil;
|
||||
|
||||
for fi:= 0 to Screen.CustomFormCount - 1 do begin
|
||||
frm:= Screen.CustomForms[fi];
|
||||
if frm.Handle = WindowPos.hwnd then continue;
|
||||
if not frm.SnapOptions.SnapFormTarget then continue;
|
||||
if GetWindowRect(frm.Handle, br) = 0 then continue;
|
||||
// Left-Right snapping
|
||||
AddGoals(Rect.Top, Rect.Bottom, br.Top, br.Bottom, br.Left, br.Right, PrevRect.Left, PrevRect.Right, SnapTo[3], SnapTo[1], SnapTo[0], SnapTo[2]);
|
||||
// Up-Down snapping
|
||||
AddGoals(Rect.Left, Rect.Right, br.Left, br.Right, br.Top, br.Bottom, PrevRect.Top, PrevRect.Bottom, SnapTo[0], SnapTo[2], SnapTo[3], SnapTo[1]);
|
||||
end;
|
||||
|
||||
{$push}
|
||||
{$BoolEval on} // do not short-circuit, SnapToSides has sideffects that must take place either way
|
||||
Result:= SnapToSides(WindowPos.x, WindowPos.cx, FPreviousSource.x, FPreviousSource.cx, FPreviousReturn.x, FPreviousReturn.cx, Opts.Distance, SnapTo[3], SnapTo[1]) or
|
||||
SnapToSides(WindowPos.y, WindowPos.cy, FPreviousSource.y, FPreviousSource.cy, FPreviousReturn.y, FPreviousReturn.cy, Opts.Distance, SnapTo[0], SnapTo[2]);
|
||||
{$pop}
|
||||
end;
|
||||
|
||||
|
||||
{ TCustomForm }
|
||||
|
||||
function TCustomForm.GetScreenSnap: boolean;
|
||||
begin
|
||||
Result:= FSnapOptions.SnapToMonitor;
|
||||
end;
|
||||
|
||||
function TCustomForm.GetSnapBuffer: integer;
|
||||
begin
|
||||
Result:= FSnapOptions.Distance;
|
||||
end;
|
||||
|
||||
procedure TCustomForm.SetScreenSnap(aValue: boolean);
|
||||
begin
|
||||
FSnapOptions.SnapToMonitor:= aValue;
|
||||
end;
|
||||
|
||||
procedure TCustomForm.SetSnapBuffer(aValue: integer);
|
||||
begin
|
||||
FSnapOptions.Distance:= aValue;
|
||||
end;
|
||||
|
||||
procedure TCustomForm.WMWindowPosChanging(var Message: TLMWindowPosChanging);
|
||||
begin
|
||||
Screen.MagnetManager.SnapForm(Self, Message.WindowPos^);
|
||||
end;
|
||||
|
||||
|
||||
// included by forms.pp
|
||||
Loading…
Reference in New Issue
Block a user