mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-05-02 02:03:39 +02:00
1083 lines
26 KiB
ObjectPascal
1083 lines
26 KiB
ObjectPascal
|
|
{*****************************************}
|
|
{ }
|
|
{ FastReport v2.3 }
|
|
{ Tool controls }
|
|
{ }
|
|
{ Copyright (c) 1998-99 by Tzyganenko A. }
|
|
{ }
|
|
{*****************************************}
|
|
|
|
unit LR_Dock;
|
|
|
|
interface
|
|
|
|
{$I LR_Vers.inc}
|
|
|
|
uses
|
|
Classes, SysUtils, LResources,LMessages,Messages,
|
|
Forms, Controls, Graphics, Dialogs,
|
|
ExtCtrls, Buttons, StdCtrls,Menus,
|
|
|
|
GraphType,LCLType,LCLIntf,LCLProc,
|
|
|
|
LR_Fpc;
|
|
|
|
type
|
|
TfrOrientation = (toAny, toVertOnly, toHorzOnly);
|
|
|
|
TfrFloatWindow = class;
|
|
|
|
TfrDock = class(TPanel)
|
|
private
|
|
FRowSize: Integer;
|
|
protected
|
|
procedure Loaded; override;
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
procedure AdjustBounds;
|
|
procedure Paint; override;
|
|
published
|
|
property RowSize: Integer read FRowSize write FRowSize default 26;
|
|
end;
|
|
|
|
TfrDragBox = class(TGraphicControl)
|
|
protected
|
|
procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
|
|
X, Y: Integer); override;
|
|
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
|
|
procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
|
|
X, Y: Integer); override;
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
procedure Paint; override;
|
|
end;
|
|
|
|
TfrToolBar = class(TPanel)
|
|
private
|
|
FDragBox: TfrDragBox;
|
|
FWindow: TfrFloatWindow;
|
|
FIsFloat: Boolean;
|
|
FDown: Boolean;
|
|
FLastX, FLastY: Integer;
|
|
FOrientation: TfrOrientation;
|
|
FCanFloat: Boolean;
|
|
function ParentAlign: TAlign;
|
|
function FindDock(AOwner: TWinControl; p: TPoint): Boolean;
|
|
procedure MakeFloat;
|
|
function MoveTo(X, Y: Integer): Boolean;
|
|
function GetVisible: Boolean;
|
|
procedure SetVisible(Value: Boolean);
|
|
procedure DockTo(aDock: TfrDock; X, Y: Integer);
|
|
procedure FloatTo(X,Y: Integer);
|
|
procedure DoMouseDown(Sender: TObject; Button: TMouseButton;
|
|
Shift: TShiftState; X, Y: Integer);
|
|
procedure DoMouseMove(Sender: TObject; Shift: TShiftState; X,
|
|
Y: Integer);
|
|
procedure DoMouseUp(Sender: TObject; Button: TMouseButton;
|
|
Shift: TShiftState; X, Y: Integer);
|
|
procedure DoResize(Sender: TObject);
|
|
procedure WMWindowPosChanged(var Message: TLMWindowPosChanged); message LM_WINDOWPOSCHANGED;
|
|
function GetFloatWindow: TForm;
|
|
protected
|
|
procedure Loaded; override;
|
|
procedure RealignControls;
|
|
function GetClientRect: TRect; override;
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
destructor Destroy; override;
|
|
procedure Paint; override;
|
|
procedure AdjustBounds;
|
|
procedure AddToDock(aDock: TfrDock);
|
|
property IsFloat: Boolean read FIsFloat;
|
|
property FloatWindow: TForm read GetFloatWindow;
|
|
property IsVisible: Boolean read GetVisible write SetVisible;
|
|
published
|
|
property CanFloat: Boolean read FCanFloat write FCanFloat default True;
|
|
property Orientation: TfrOrientation read FOrientation write FOrientation;
|
|
end;
|
|
|
|
TfrFloatWindow = class(TForm)
|
|
procedure FormShow(Sender: TObject);
|
|
procedure FormDestroy(Sender: TObject);
|
|
private
|
|
FRect: TRect;
|
|
FDown: Boolean;
|
|
procedure WMNCHitTest(var Msg: TWMNCHitTest); message WM_NCHITTEST;
|
|
protected
|
|
procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
|
|
X, Y: Integer); override;
|
|
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
|
|
procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
|
|
X, Y: Integer); override;
|
|
public
|
|
ToolBar: TfrToolBar;
|
|
procedure Capture;
|
|
end;
|
|
|
|
var
|
|
RegRootKey: String;
|
|
|
|
const
|
|
rsToolBar = 'ToolBar\';
|
|
rsForm = 'Form\';
|
|
rsWidth = 'Width';
|
|
rsHeight = 'Height';
|
|
rsTop = 'Top';
|
|
rsLeft = 'Left';
|
|
rsFloat = 'isFloat';
|
|
rsVisible = 'isVisible';
|
|
rsX = 'XPosition';
|
|
rsY = 'YPosition';
|
|
rsDockName = 'DockName';
|
|
|
|
procedure SaveToolbarPosition(t: TfrToolBar);
|
|
procedure RestoreToolbarPosition(t: TfrToolBar);
|
|
procedure SaveFormPosition(f: TForm);
|
|
procedure RestoreFormPosition(f: TForm);
|
|
|
|
procedure Register;
|
|
|
|
implementation
|
|
|
|
{$R *.lfm}
|
|
|
|
uses Registry;
|
|
|
|
var
|
|
FloatingToolBars: TFpList;
|
|
|
|
|
|
procedure AddToToolbarList(t: TfrToolBar);
|
|
begin
|
|
if FloatingToolbars.IndexOf(t) <> -1 then
|
|
FloatingToolbars.Add(t);
|
|
end;
|
|
|
|
procedure RemoveFromToolbarList(t: TfrToolBar);
|
|
var
|
|
i: Integer;
|
|
begin
|
|
i := FloatingToolbars.IndexOf(t);
|
|
if i <> -1 then
|
|
FloatingToolbars.Delete(i);
|
|
end;
|
|
|
|
procedure DestroyToolbarList;
|
|
var
|
|
i: Integer;
|
|
begin
|
|
for i := 0 to FloatingToolBars.Count-1 do
|
|
TfrToolBar(FloatingToolBars[i]).Free;
|
|
end;
|
|
|
|
|
|
procedure SaveToolbarPosition(t: TfrToolBar);
|
|
var
|
|
Ini: TRegIniFile;
|
|
X, Y: integer;
|
|
Name: String;
|
|
begin
|
|
Ini := TRegIniFile.Create(RegRootKey);
|
|
Name := rsToolbar + t.Name;
|
|
Ini.WriteBool(Name, rsFloat, t.isFloat);
|
|
Ini.WriteBool(Name, rsVisible, t.IsVisible);
|
|
X := t.Left; Y := t.Top;
|
|
if t.IsFloat then
|
|
begin
|
|
X := t.FloatWindow.Left; Y := t.FloatWindow.Top;
|
|
end;
|
|
Ini.WriteInteger(Name, rsX, X);
|
|
Ini.WriteInteger(Name, rsY, Y);
|
|
Ini.WriteInteger(Name, rsWidth, t.Width);
|
|
Ini.WriteInteger(Name, rsHeight, t.Height);
|
|
if t.Parent is TfrDock then
|
|
Ini.WriteString(Name, rsDockName, t.Parent.Name);
|
|
Ini.Free;
|
|
end;
|
|
|
|
procedure RestoreToolbarPosition(t: TfrToolBar);
|
|
var
|
|
Ini: TRegIniFile;
|
|
X, Y: Integer;
|
|
DN: string;
|
|
NewDock: TfrDock;
|
|
Name: String;
|
|
begin
|
|
Ini := TRegIniFile.Create(RegRootKey);
|
|
Name := rsToolbar + t.Name;
|
|
t.IsVisible := False;
|
|
X := Ini.ReadInteger(Name, rsX, t.Left);
|
|
Y := Ini.ReadInteger(Name, rsY, t.Top);
|
|
t.Width := Ini.ReadInteger(Name, rsWidth, t.Width);
|
|
t.Height := Ini.ReadInteger(Name, rsHeight, t.Height);
|
|
if Ini.ReadBool(Name, rsFloat, False) then
|
|
t.FloatTo(X, Y)
|
|
else
|
|
begin
|
|
t.Left := X;
|
|
t.Top := Y;
|
|
DN := Ini.ReadString(Name, rsDockName, t.Parent.Name);
|
|
if (t.Owner <> nil) then
|
|
begin
|
|
NewDock := t.Owner.FindComponent(DN) as TfrDock;
|
|
if (NewDock <> nil) and (NewDock <> t.Parent) then
|
|
t.DockTo(NewDock, X, Y);
|
|
end;
|
|
t.AdjustBounds;
|
|
end;
|
|
t.IsVisible := Ini.ReadBool(Name, rsVisible, True);
|
|
Ini.Free;
|
|
end;
|
|
|
|
procedure SaveFormPosition(f: TForm);
|
|
var
|
|
Ini: TRegIniFile;
|
|
Name: String;
|
|
begin
|
|
Ini := TRegIniFile.Create(RegRootKey);
|
|
Name := rsForm + f.Name;
|
|
Ini.WriteBool(Name, rsVisible, f.Visible);
|
|
Ini.WriteInteger(Name, rsX, f.Left);
|
|
Ini.WriteInteger(Name, rsY, f.Top);
|
|
Ini.WriteInteger(Name, rsWidth, f.Width);
|
|
Ini.WriteInteger(Name, rsHeight, f.Height);
|
|
Ini.Free;
|
|
end;
|
|
|
|
procedure RestoreFormPosition(f: TForm);
|
|
var
|
|
Ini: TRegIniFile;
|
|
Name: String;
|
|
begin
|
|
Ini := TRegIniFile.Create(RegRootKey);
|
|
Name := rsForm + f.Name;
|
|
f.Hide;
|
|
f.Left := Ini.ReadInteger(Name, rsX, f.Left);
|
|
f.Top := Ini.ReadInteger(Name, rsY, f.Top);
|
|
f.Width := Ini.ReadInteger(Name, rsWidth, f.Width);
|
|
f.Height := Ini.ReadInteger(Name, rsHeight, f.Height);
|
|
if Ini.ReadBool(Name, rsVisible, True) then
|
|
f.Show;
|
|
Ini.Free;
|
|
end;
|
|
|
|
|
|
{--------------------------------------------------------------------------}
|
|
constructor TfrDock.Create(AOwner: TComponent);
|
|
begin
|
|
inherited Create(AOwner);
|
|
RowSize := 26;
|
|
end;
|
|
|
|
procedure TfrDock.Loaded;
|
|
begin
|
|
inherited Loaded;
|
|
AdjustBounds;
|
|
end;
|
|
|
|
procedure TfrDock.AdjustBounds;
|
|
var
|
|
i, Line, LineCount, l, dl: Integer;
|
|
CtlOnLine, NewSize: Integer;
|
|
c: TControl;
|
|
ShiftNeeded: Boolean;
|
|
begin
|
|
if ControlCount = 0 then
|
|
begin
|
|
if Align in [alTop, alBottom] then
|
|
Height := 1 else
|
|
Width := 1;
|
|
Exit;
|
|
end;
|
|
if Align in [alTop, alBottom] then
|
|
L := Height else
|
|
L := Width;
|
|
LineCount := L div RowSize;
|
|
NewSize := RowSize * LineCount + 1;
|
|
L := 0;
|
|
dL := RowSize;
|
|
if Align in [alRight, alBottom] then
|
|
begin
|
|
dL := -RowSize;
|
|
if Align = alRight then
|
|
L := Width else
|
|
L := Height;
|
|
end;
|
|
Line := 0;
|
|
while Line < LineCount do
|
|
begin
|
|
CtlOnLine := 0;
|
|
for i := 0 to ControlCount-1 do
|
|
begin
|
|
c := Controls[i];
|
|
if c.Visible then
|
|
case Align of
|
|
alLeft:
|
|
if (c.Left = L) or
|
|
((c.Left < L) and (c.Left + c.Width > L)) then Inc(CtlOnLine);
|
|
alRight:
|
|
if (c.Left + c.Width = L) or
|
|
((c.Left + c.Width > L) and (c.Left < L)) then Inc(CtlOnLine);
|
|
alTop:
|
|
if (c.Top = L) or
|
|
((c.Top < L) and (c.Top + c.Height > L)) then Inc(CtlOnLine);
|
|
alBottom:
|
|
if (c.Top + c.Height = L) or
|
|
((c.Top + c.Height > L) and (c.Top < L)) then Inc(CtlOnLine);
|
|
end;
|
|
end;
|
|
if CtlOnLine = 0 then
|
|
begin
|
|
for i := 0 to ControlCount-1 do
|
|
begin
|
|
c := Controls[i];
|
|
if c.Visible then
|
|
begin
|
|
if ((Align = alLeft) and (c.Left > L)) or
|
|
((Align = alRight) and (c.Left + c.Width > L)) then
|
|
c.Left := c.Left - RowSize;
|
|
if ((Align = alTop) and (c.Top > L)) or
|
|
((Align = alBottom) and (c.Top + c.Height > L)) then
|
|
c.Top := c.Top - RowSize;
|
|
end;
|
|
end;
|
|
Dec(NewSize, RowSize);
|
|
Dec(LineCount);
|
|
Dec(Line);
|
|
if Align in [alTop, alLeft] then Dec(L, dL);
|
|
end;
|
|
Inc(Line);
|
|
Inc(L, dL);
|
|
end;
|
|
|
|
ShiftNeeded := False;
|
|
for i := 0 to ControlCount-1 do
|
|
begin
|
|
c := Controls[i];
|
|
if c.Visible then
|
|
begin
|
|
if (Align = alRight) and (c.Left < 0) then
|
|
begin
|
|
ShiftNeeded := True;
|
|
L := -c.Left + 1;
|
|
Inc(NewSize, L);
|
|
break;
|
|
end;
|
|
if (Align = alBottom) and (c.Top < 0) then
|
|
begin
|
|
ShiftNeeded := True;
|
|
L := -c.Top + 1;
|
|
Inc(NewSize, L);
|
|
break;
|
|
end;
|
|
if (Align = alTop) and (c.Top + c.Height > NewSize) then
|
|
begin
|
|
NewSize := c.Top + c.Height + 1;
|
|
break;
|
|
end;
|
|
if (Align = alLeft) and (c.Left + c.Width > NewSize) then
|
|
begin
|
|
NewSize := c.Left + c.Width + 1;
|
|
break;
|
|
end;
|
|
end;
|
|
end;
|
|
if ShiftNeeded then
|
|
for i := 0 to ControlCount-1 do
|
|
begin
|
|
c := Controls[i];
|
|
if c.Visible then
|
|
if Align = alRight then
|
|
c.Left := c.Left + L
|
|
else if Align = alBottom then
|
|
c.Top := c.Top + L;
|
|
end;
|
|
|
|
for i := 0 to ControlCount-1 do
|
|
begin
|
|
c := Controls[i];
|
|
if c.Visible then
|
|
begin
|
|
if (Align = alRight) and (c.Left + c.Width > NewSize) then
|
|
NewSize := c.Left + c.Width;
|
|
if (Align = alBottom) and (c.Top + c.Height > NewSize) then
|
|
NewSize := c.Top + c.Height;
|
|
end;
|
|
end;
|
|
|
|
case Align of
|
|
alTop: Height := NewSize;
|
|
alLeft: Width := NewSize;
|
|
alBottom:
|
|
if Height < NewSize then
|
|
SetBounds(0, Top - (NewSize - Height), Width, NewSize)
|
|
else
|
|
Height := NewSize;
|
|
alRight:
|
|
if Width < NewSize then
|
|
SetBounds(Left - (NewSize - Width), Top, NewSize, Height)
|
|
else
|
|
Width := NewSize;
|
|
end;
|
|
end;
|
|
|
|
procedure TfrDock.Paint;
|
|
var
|
|
R: TRect;
|
|
begin
|
|
with Canvas do
|
|
begin
|
|
Brush.Color := clBtnFace;
|
|
R := Rect(0, 0, Width, Height);
|
|
FillRect(R);
|
|
if csDesigning in ComponentState then
|
|
begin
|
|
Pen.Color := clBtnShadow;
|
|
Rectangle(0, 0, Width, Height);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
|
|
{--------------------------------------------------------------------------}
|
|
constructor TfrDragBox.Create(AOwner: TComponent);
|
|
begin
|
|
inherited Create(AOwner);
|
|
Width := 11;
|
|
Height := 11;
|
|
end;
|
|
|
|
procedure TfrDragBox.Paint;
|
|
var
|
|
R: TRect;
|
|
begin
|
|
with Canvas do
|
|
begin
|
|
Brush.Color := clBtnFace;
|
|
R := Rect(0, 0, Width, Height);
|
|
FillRect(R);
|
|
end;
|
|
if (Parent as TfrToolBar).ParentAlign = alTop then
|
|
begin
|
|
R := Rect(2, 0, 5, Height);
|
|
Frame3D(Canvas, R, clBtnHighlight, clBtnShadow,1);
|
|
R := Rect(5, 0, 8, Height);
|
|
Frame3D(Canvas, R, clBtnHighlight, clBtnShadow, 1);
|
|
end
|
|
else if (Parent as TfrToolBar).ParentAlign = alLeft then
|
|
begin
|
|
R := Rect(0, 2, Width, 5);
|
|
Frame3D(Canvas, R, clBtnHighlight, clBtnShadow, 1);
|
|
R := Rect(0, 5, Width, 8);
|
|
Frame3D(Canvas, R, clBtnHighlight, clBtnShadow, 1);
|
|
end;
|
|
end;
|
|
|
|
procedure TfrDragBox.MouseDown(Button: TMouseButton; Shift: TShiftState;
|
|
X, Y: Integer);
|
|
var
|
|
p: TPoint;
|
|
begin
|
|
p := ClientToScreen(Point(X, Y));
|
|
p := Parent.ScreenToClient(p);
|
|
(Parent as TfrToolBar).DoMouseDown(Self, Button, Shift, P.X, P.Y);
|
|
end;
|
|
|
|
procedure TfrDragBox.MouseMove(Shift: TShiftState; X, Y: Integer);
|
|
var
|
|
p: TPoint;
|
|
begin
|
|
p := ClientToScreen(Point(X, Y));
|
|
p := Parent.ScreenToClient(p);
|
|
(Parent as TfrToolBar).DoMouseMove(Self, Shift, P.X, P.Y);
|
|
end;
|
|
|
|
procedure TfrDragBox.MouseUp(Button: TMouseButton; Shift: TShiftState;
|
|
X, Y: Integer);
|
|
var
|
|
p: TPoint;
|
|
begin
|
|
p := ClientToScreen(Point(X, Y));
|
|
p := Parent.ScreenToClient(p);
|
|
(Parent as TfrToolBar).DoMouseUp(Self, Button, Shift, P.X, P.Y);
|
|
end;
|
|
|
|
|
|
{--------------------------------------------------------------------------}
|
|
constructor TfrToolBar.Create(AOwner: TComponent);
|
|
begin
|
|
inherited Create(AOwner);
|
|
Height := 26;
|
|
FDragBox := TfrDragBox.Create(Self);
|
|
FDragBox.Parent := Self;
|
|
FDragBox.Align := alLeft;
|
|
FullRepaint := False;
|
|
OnMouseDown := @DoMouseDown;
|
|
OnMouseMove := @DoMouseMove;
|
|
OnMouseUp := @DoMouseUp;
|
|
OnResize := @DoResize;
|
|
FCanFloat := True;
|
|
FOrientation := toAny;
|
|
end;
|
|
|
|
destructor TfrToolBar.Destroy;
|
|
begin
|
|
FDragBox.Free;
|
|
if FWindow <> nil then
|
|
begin
|
|
Parent := nil;
|
|
FWindow.Hide;
|
|
FWindow.Free;
|
|
end;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
procedure TfrToolBar.Loaded;
|
|
begin
|
|
inherited Loaded;
|
|
AdjustBounds;
|
|
end;
|
|
|
|
procedure TfrToolBar.Paint;
|
|
var
|
|
R: TRect;
|
|
begin
|
|
with Canvas do
|
|
begin
|
|
Brush.Color := clBtnFace;
|
|
R := Rect(0, 0, Width, Height);
|
|
FillRect(R);
|
|
if not IsFloat then
|
|
LR_Fpc.Frame3D(Canvas, R, clBtnHighlight, clBtnShadow, 1);
|
|
end;
|
|
end;
|
|
|
|
function TfrToolBar.ParentAlign: TAlign;
|
|
begin
|
|
Result := Parent.Align;
|
|
if Result = alBottom then Result := alTop;
|
|
if Result = alRight then Result := alLeft;
|
|
end;
|
|
|
|
function TfrToolBar.GetClientRect: TRect;
|
|
begin
|
|
Result := inherited GetClientRect;
|
|
InflateRect(Result, -1, -1);
|
|
end;
|
|
|
|
function TfrToolBar.GetVisible: Boolean;
|
|
begin
|
|
if IsFloat then
|
|
Result := FWindow.Visible else
|
|
Result := Visible;
|
|
end;
|
|
|
|
procedure TfrToolBar.SetVisible(Value: Boolean);
|
|
begin
|
|
if IsFloat then
|
|
FWindow.Visible := Value else
|
|
Visible := Value;
|
|
end;
|
|
|
|
procedure TfrToolBar.DockTo(aDock: TfrDock; X, Y: Integer);
|
|
var
|
|
oldParent: TfrDock;
|
|
begin
|
|
Hide;
|
|
if FWindow <> nil then
|
|
begin
|
|
FWindow.Hide;
|
|
FWindow.Release;
|
|
Parent := nil;
|
|
end;
|
|
FWindow := nil;
|
|
oldParent := nil;
|
|
if (Parent <> nil) and (Parent is TfrDock) then
|
|
oldParent := Parent as TfrDock;
|
|
Parent := aDock;
|
|
if oldParent <> nil then
|
|
oldParent.AdjustBounds;
|
|
FIsFloat := False;
|
|
FDragBox.Show;
|
|
RealignControls;
|
|
Left := X; Top := Y;
|
|
Show;
|
|
aDock.AdjustBounds;
|
|
RemoveFromToolbarList(Self);
|
|
end;
|
|
|
|
procedure TfrToolBar.AddToDock(aDock: TfrDock);
|
|
var
|
|
X,Y: Integer;
|
|
begin
|
|
X := 0;
|
|
Y := 0;
|
|
case aDock.Align of
|
|
alTop:
|
|
begin
|
|
X := 0;
|
|
Y := aDock.Height - 1;
|
|
end;
|
|
alBottom:
|
|
begin
|
|
X := 0;
|
|
Y := -Height + 1;
|
|
end;
|
|
alLeft:
|
|
begin
|
|
X := aDock.Width - 1;
|
|
Y := 0;
|
|
end;
|
|
alRight:
|
|
begin
|
|
X := -Width + 1;
|
|
Y := 0;
|
|
end;
|
|
end;
|
|
DockTo(aDock, X, Y);
|
|
end;
|
|
|
|
function TfrToolBar.FindDock(AOwner: TWinControl; p: TPoint): Boolean;
|
|
var
|
|
i: Integer;
|
|
c: TControl;
|
|
d: TfrDock;
|
|
begin
|
|
Result := False;
|
|
for i := 0 to AOwner.ControlCount-1 do
|
|
begin
|
|
c := AOwner.Controls[i];
|
|
if c is TfrDock then
|
|
if (p.X >= c.Left) and (p.X <= c.Left + c.Width) and
|
|
(p.Y >= c.Top) and (p.Y <= c.Top + c.Height) then
|
|
begin
|
|
with c as TfrDock do
|
|
if ((FOrientation = toHorzOnly) and (Align in [alLeft, alRight])) or
|
|
((FOrientation = toVertOnly) and (Align in [alTop, alBottom])) then
|
|
break;
|
|
d := c as TfrDock;
|
|
if d.Align in [alTop,alBottom] then
|
|
begin
|
|
p := Point(p.X - d.Left, d.Height - 1);
|
|
if p.X + Width > d.Width then
|
|
p.X := d.Width - Width;
|
|
if p.X < 0 then p.X := 0;
|
|
if d.Align = alBottom then
|
|
p.Y := -Height + 1;
|
|
end
|
|
else
|
|
begin
|
|
p := Point(d.Width - 1, p.Y - d.Top);
|
|
if p.Y + Height > d.Height then
|
|
p.Y := d.Height - Height;
|
|
if p.Y < 0 then p.Y := 0;
|
|
if d.Align = alRight then
|
|
p.X := -Height + 1;
|
|
end;
|
|
DockTo(d, p.X, p.Y);
|
|
SetCaptureControl(Self);
|
|
DoMouseDown(Self, mbLeft, [], 0, 0);
|
|
Result := True;
|
|
break;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TfrToolBar.RealignControls;
|
|
var
|
|
i, j, t: Integer;
|
|
TempCtrl: TControl;
|
|
Ctrls: Array[0..100] of TControl;
|
|
begin
|
|
for i := 0 to ControlCount-1 do
|
|
Ctrls[i] := Controls[i];
|
|
for i := 0 to ControlCount-1 do
|
|
for j := 0 to ControlCount-2 do
|
|
if Parent.Align in [alTop, alBottom, alNone] then
|
|
begin
|
|
if Ctrls[j].Left > Ctrls[j + 1].Left then
|
|
begin
|
|
TempCtrl := Ctrls[j + 1];
|
|
Ctrls[j + 1] := Ctrls[j];
|
|
Ctrls[j] := TempCtrl;
|
|
end;
|
|
end
|
|
else
|
|
begin
|
|
if (Ctrls[j].Align in [alTop, alBottom]) and
|
|
(Ctrls[j + 1].Align in [alTop, alBottom]) and
|
|
(Ctrls[j].Top > Ctrls[j + 1].Top) then
|
|
begin
|
|
TempCtrl := Ctrls[j];
|
|
Ctrls[j] := Ctrls[j + 1];
|
|
Ctrls[j + 1] := TempCtrl;
|
|
end;
|
|
end;
|
|
case Parent.Align of
|
|
alTop, alBottom, alNone:
|
|
begin
|
|
if Height > Width then
|
|
begin
|
|
t := Width;
|
|
Width := Height;
|
|
Height := t;
|
|
end;
|
|
for t := 0 to ControlCount-1 do
|
|
if Ctrls[t] <> nil then
|
|
if not (Ctrls[t].Align in [alLeft, alRight]) then
|
|
if (Ctrls[t].Align = alBottom) then
|
|
Ctrls[t].Align := alRight
|
|
else
|
|
begin
|
|
Ctrls[t].Left := Ctrls[t].Top;
|
|
Ctrls[t].Align := alLeft;
|
|
end;
|
|
end;
|
|
alLeft, alRight:
|
|
begin
|
|
if Width > Height then
|
|
begin
|
|
t := Width;
|
|
Width := Height;
|
|
Height := t;
|
|
end;
|
|
for t := 0 to ControlCount-1 do
|
|
if Ctrls[t] <> nil then
|
|
if not (Ctrls[t].Align in [alTop, alBottom]) then
|
|
if (Ctrls[t].Align = alRight) then
|
|
Ctrls[t].Align := alBottom
|
|
else
|
|
begin
|
|
Ctrls[t].Top := Ctrls[t].Left;
|
|
Ctrls[t].Align := alTop;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TfrToolBar.AdjustBounds;
|
|
var
|
|
i, max: Integer;
|
|
c: TControl;
|
|
begin
|
|
RealignControls;
|
|
max := 0;
|
|
for i := 0 to ControlCount-1 do
|
|
begin
|
|
c := Controls[i];
|
|
if Parent.Align in [alTop, alBottom, alNone] then
|
|
Inc(max, c.Width)
|
|
else
|
|
Inc(max, c.Height);
|
|
end;
|
|
if Parent.Align in [alTop, alBottom, alNone] then
|
|
Width := max + 4 else
|
|
Height := max + 4;
|
|
end;
|
|
|
|
procedure TfrToolBar.MakeFloat;
|
|
var
|
|
p: TPoint;
|
|
begin
|
|
FIsFloat := True;
|
|
GetCursorPos(p);
|
|
FloatTo(p.X, p.Y);
|
|
FWindow.Capture;
|
|
end;
|
|
|
|
procedure TfrToolBar.FloatTo(X, Y: Integer);
|
|
var
|
|
oldParent: TfrDock;
|
|
begin
|
|
FIsFloat := True;
|
|
if FWindow = nil then
|
|
begin
|
|
oldParent := nil;
|
|
if (Parent <> nil) and (Parent is TfrDock) then
|
|
oldParent := Parent as TfrDock;
|
|
Hide;
|
|
FDragBox.Visible:=False;
|
|
FWindow := TfrFloatWindow.Create(GetParentForm(Self));
|
|
FWindow.BorderStyle := bsToolWindow;
|
|
FWindow.Left := X;
|
|
FWindow.Top := Y;
|
|
FWindow.Caption := Caption;
|
|
FWindow.FormStyle := fsStayOnTop;
|
|
Parent := FWindow;
|
|
RealignControls;
|
|
if oldParent <> nil then
|
|
oldParent.AdjustBounds;
|
|
FWindow.ClientWidth := Width - 11;
|
|
FWindow.ClientHeight := Height;
|
|
FWindow.ToolBar := Self;
|
|
Left := 0; Top := 0;
|
|
Show;
|
|
AddToToolbarList(Self);
|
|
end
|
|
else
|
|
FWindow.SetBounds(X, Y, FWindow.Width, FWindow.Height);
|
|
end;
|
|
|
|
function TfrToolBar.MoveTo(X, Y: Integer): Boolean;
|
|
var
|
|
i, n, oldSize, ShiftCount: Integer;
|
|
c: TControl;
|
|
|
|
procedure Shift(ax,ay:Integer);
|
|
begin
|
|
x := ax;
|
|
y := ay;
|
|
Inc(ShiftCount);
|
|
end;
|
|
|
|
begin
|
|
Result := True;
|
|
if IsFloat then Exit;
|
|
n := 0;
|
|
repeat
|
|
ShiftCount := 0;
|
|
|
|
if ParentAlign = alTop then
|
|
begin
|
|
if x < -20 then
|
|
FIsFloat := True;
|
|
if x < 0 then Shift(0, y);
|
|
if x + Width > Parent.Width then
|
|
Shift(Parent.Width - Width, y);
|
|
end
|
|
else // if ParentAlign = alLeft then
|
|
begin
|
|
if y < -20 then
|
|
FIsFloat := True;
|
|
if y < 0 then Shift(x, 0);
|
|
if y + Height > Parent.Height then
|
|
Shift(x, Parent.Height - Height);
|
|
end;
|
|
|
|
if not IsFloat then
|
|
for i := 0 to Parent.ControlCount-1 do
|
|
begin
|
|
c := Parent.Controls[i];
|
|
if (c <> Self) and c.Visible then
|
|
if ParentAlign = alTop then
|
|
begin
|
|
if ((y >= c.Top) and (y < c.Top + c.Height)) or
|
|
((y <= c.Top) and (y + Height > c.Top)) then
|
|
begin
|
|
if (x >= c.Left) and (x < c.Left + c.Width) then
|
|
Shift(c.Left + c.Width, y);
|
|
if (x < c.Left) and (x + Width > c.Left) then
|
|
Shift(c.Left - Width, y);
|
|
end;
|
|
end
|
|
else // if ParentAlign = alLeft then
|
|
begin
|
|
if ((x >= c.Left) and (x < c.Left + c.Width)) or
|
|
((x <= c.Left) and (x + Width > c.Left)) then
|
|
begin
|
|
if (y >= c.Top) and (y < c.Top + c.Height) then
|
|
Shift(x, c.Top + c.Height);
|
|
if (y < c.Top) and (y + Height > c.Top) then
|
|
Shift(x, c.Top - Height);
|
|
end;
|
|
end;
|
|
end;
|
|
Inc(n);
|
|
until (n > 3) or (ShiftCount = 0) or IsFloat;
|
|
|
|
if not FCanFloat then
|
|
FIsFloat := False;
|
|
|
|
if IsFloat then
|
|
MakeFloat
|
|
else
|
|
if n < 3 then
|
|
begin
|
|
{$IFDEF DebugLR}
|
|
DebugLn('n < 3');
|
|
{$ENDIF}
|
|
if ParentAlign = alTop then
|
|
if (y + Height > Parent.Height) or (y < 0) then
|
|
oldSize := Parent.Height else
|
|
oldSize := 0
|
|
else
|
|
if (x + Width > Parent.Width) or (x < 0) then
|
|
oldSize := Parent.Width else
|
|
oldSize := 0;
|
|
Left := x;
|
|
Top := y;
|
|
(Parent as TfrDock).AdjustBounds;
|
|
if FCanFloat then
|
|
if ((ParentAlign = alTop) and (Parent.Height = oldSize)) or
|
|
((ParentAlign = alLeft) and (Parent.Width = oldSize)) then
|
|
MakeFloat;
|
|
end
|
|
else Result := False;
|
|
end;
|
|
|
|
procedure TfrToolBar.DoMouseDown(Sender: TObject; Button: TMouseButton;
|
|
Shift: TShiftState; X, Y: Integer);
|
|
var
|
|
p: TPoint;
|
|
begin
|
|
GetCursorPos(p);
|
|
FLastX := p.X; FLastY := p.Y;
|
|
FDown := True;
|
|
end;
|
|
|
|
procedure TfrToolBar.DoMouseMove(Sender: TObject; Shift: TShiftState; X,
|
|
Y: Integer);
|
|
var
|
|
p: TPoint;
|
|
dx, dy: Integer;
|
|
StepX, StepY: Integer;
|
|
b: Boolean;
|
|
begin
|
|
if IsFloat then
|
|
begin
|
|
Cursor := crDefault;
|
|
FDown := False;
|
|
Exit;
|
|
end;
|
|
if not FDown then Exit;
|
|
GetCursorPos(p);
|
|
if ParentAlign = alTop then
|
|
StepY := (Parent as TfrDock).RowSize else
|
|
StepY := 1;
|
|
if ParentAlign = alLeft then
|
|
StepX := (Parent as TfrDock).RowSize else
|
|
StepX := 1;
|
|
dx := (p.X - FLastX) div StepX * StepX;
|
|
dy := (p.Y - FLastY) div StepY * StepY;
|
|
b := False;
|
|
if (dx <> 0) or (dy <> 0) then
|
|
b := MoveTo(Left + dx, Top + dy);
|
|
if b then
|
|
begin
|
|
if dx <> 0 then FLastX := p.X;
|
|
if dy <> 0 then FLastY := p.Y;
|
|
end;
|
|
end;
|
|
|
|
procedure TfrToolBar.DoMouseUp(Sender: TObject; Button: TMouseButton;
|
|
Shift: TShiftState; X, Y: Integer);
|
|
begin
|
|
FDown := False;
|
|
end;
|
|
|
|
procedure TfrToolBar.DoResize(Sender: TObject);
|
|
begin
|
|
if csDestroying in ComponentState then Exit;
|
|
FDragBox.SetBounds(0, 0, 11, 11);
|
|
if ParentAlign = alTop then
|
|
FDragBox.Align := alLeft else
|
|
FDragBox.Align := alTop;
|
|
end;
|
|
|
|
procedure TfrToolBar.WMWindowPosChanged(var Message: TLMWindowPosChanged);
|
|
begin
|
|
if csDesigning in ComponentState then
|
|
inherited else
|
|
DefaultHandler(Message);
|
|
end;
|
|
|
|
function TfrToolBar.GetFloatWindow: TForm;
|
|
begin
|
|
Result := FWindow;
|
|
end;
|
|
|
|
|
|
{----------------------------------------------------------------------------}
|
|
procedure DrawFrameRect(R: TRect);
|
|
var
|
|
DC: HDC;
|
|
i: Integer;
|
|
begin
|
|
DC := GetDC(0);
|
|
for i := 0 to 3 do
|
|
begin
|
|
//**DrawFocusRect(DC, R);
|
|
InflateRect(R, -1, -1);
|
|
end;
|
|
ReleaseDC(0, DC);
|
|
end;
|
|
|
|
procedure TfrFloatWindow.Capture;
|
|
begin
|
|
SetCaptureControl(Self);
|
|
MouseDown(mbLeft, [], 0, 0);
|
|
end;
|
|
|
|
procedure TfrFloatWindow.WMNCHitTest(var Msg: TWMNCHitTest);
|
|
begin
|
|
inherited;
|
|
if Msg.Result = htCaption then Msg.Result := htClient;
|
|
end;
|
|
|
|
procedure TfrFloatWindow.MouseDown(Button: TMouseButton; Shift: TShiftState;
|
|
X, Y: Integer);
|
|
var
|
|
p: TPoint;
|
|
begin
|
|
GetCursorPos(p);
|
|
FRect := Rect(p.X, p.Y, p.X + Width, p.Y + Height);
|
|
Application.ProcessMessages;
|
|
DrawFrameRect(FRect);
|
|
FDown := True;
|
|
end;
|
|
|
|
procedure TfrFloatWindow.MouseMove(Shift: TShiftState; X, Y: Integer);
|
|
var
|
|
p: TPoint;
|
|
begin
|
|
if not FDown then Exit;
|
|
GetCursorPos(p);
|
|
DrawFrameRect(FRect);
|
|
FRect := Rect(p.X, p.Y, p.X + Width, p.Y + Height);
|
|
if ToolBar.FindDock(Owner as TWinControl,
|
|
(Owner as TWinControl).ScreenToClient(Point(p.X, p.Y))) then
|
|
Exit;
|
|
DrawFrameRect(FRect);
|
|
end;
|
|
|
|
procedure TfrFloatWindow.MouseUp(Button: TMouseButton; Shift: TShiftState;
|
|
X, Y: Integer);
|
|
begin
|
|
DrawFrameRect(FRect);
|
|
MoveWindowOrg(Handle,FRect.Left, FRect.Top);
|
|
// MoveWindow(Handle, FRect.Left, FRect.Top, Width, Height, True);
|
|
Show;
|
|
FDown := False;
|
|
end;
|
|
|
|
procedure TfrFloatWindow.FormShow(Sender: TObject);
|
|
begin
|
|
SetWindowPos(Handle, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE or
|
|
SWP_NOSIZE or SWP_NOACTIVATE);
|
|
end;
|
|
|
|
procedure TfrFloatWindow.FormDestroy(Sender: TObject);
|
|
begin
|
|
if ToolBar <> nil then
|
|
ToolBar.FWindow := nil;
|
|
end;
|
|
|
|
|
|
procedure Register;
|
|
begin
|
|
RegisterComponents('LR Tools', [TfrToolBar,TfrDock]);
|
|
end;
|
|
|
|
{----------------------------------------------------------------------------}
|
|
initialization
|
|
|
|
FloatingToolBars := TFpList.Create;
|
|
RegRootKey := 'Software\FastReport';
|
|
|
|
finalization
|
|
|
|
DestroyToolbarList;
|
|
FloatingToolBars.Free;
|
|
end.
|