1114 lines
29 KiB
ObjectPascal
1114 lines
29 KiB
ObjectPascal
|
|
{******************************************}
|
|
{ }
|
|
{ FastReport VCL }
|
|
{ Tool controls }
|
|
{ }
|
|
{ Copyright (c) 1998-2021 }
|
|
{ by Fast Reports Inc. }
|
|
{ }
|
|
{******************************************}
|
|
|
|
unit frxDock;
|
|
|
|
interface
|
|
|
|
{$I frx.inc}
|
|
|
|
uses
|
|
{$IFNDEF FPC}Windows, Messages, {$ENDIF}
|
|
SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
|
|
ExtCtrls, StdCtrls, ComCtrls, Buttons, frxDPIAwareInt, frxDPIAwareBaseControls, IniFiles,
|
|
frxBaseForm
|
|
{$IFDEF FPC}
|
|
, LazarusPackageIntf, LazHelper, types
|
|
{$ENDIF}
|
|
{$IFDEF Delphi6}
|
|
, Variants
|
|
{$ENDIF};
|
|
|
|
|
|
type
|
|
{$IFDEF DELPHI16}
|
|
[ComponentPlatformsAttribute(pidWin32 or pidWin64)]
|
|
{$ENDIF}
|
|
TfrxTBPanel = class(TPanel)
|
|
protected
|
|
procedure SetParent(AParent:TWinControl); override;
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
procedure Paint; override;
|
|
end;
|
|
|
|
{$IFDEF DELPHI16}
|
|
[ComponentPlatformsAttribute(pidWin32 or pidWin64)]
|
|
{$ENDIF}
|
|
TfrxDockSite = class(TfrxDPIAwarePanel)
|
|
private
|
|
FPanelSize: Integer;
|
|
FSavedSize: Integer;
|
|
FSplitter: TControl;
|
|
FTopParentWin: TWinControl;
|
|
protected
|
|
procedure VisibleChanging; override;
|
|
procedure DoPPIChanged(aNewPPI: Integer); override;
|
|
{$IFNDEF FPC}
|
|
function CreateDockManager: IDockManager; override;
|
|
{$ENDIF}
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
procedure DockDrop(Source: TDragDockObject; X, Y: Integer); override;
|
|
procedure DockOver(Source: TDragDockObject; X, Y: Integer;
|
|
State: TDragState; var Accept: Boolean); override;
|
|
function DoUnDock(NewTarget: TWinControl; Client: TControl
|
|
{$IFDEF FPC}; KeepDockSiteSize: Boolean = true{$ENDIF}): Boolean; override;
|
|
procedure SetParent(AParent: TWinControl); override;
|
|
procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
|
|
procedure ReloadDockedControl(const AControlName: string;
|
|
var AControl: TControl); override;
|
|
procedure UpdateAlign;
|
|
property SavedSize: Integer read FSavedSize write FSavedSize;
|
|
property TopParentWin: TWinControl read FTopParentWin write FTopParentWin;
|
|
end;
|
|
|
|
{$IFNDEF FPC}
|
|
TBlueForm = class(TForm)
|
|
protected
|
|
procedure CreateParams(var Params: TCreateParams); override;
|
|
end;
|
|
|
|
TfrxDragDockObject = class {$IFDEF VER130}(TDragDockObject){$ELSE}(TDragDockObjectEx){$ENDIF}
|
|
private
|
|
BlueForm: TBlueForm;
|
|
protected
|
|
procedure DrawDragDockImage; override;
|
|
procedure EraseDragDockImage; override;
|
|
public
|
|
constructor Create(AControl: TControl); override;
|
|
destructor Destroy; override;
|
|
end;
|
|
|
|
TfrxDockForm = class(TfrxBaseForm)
|
|
protected
|
|
procedure DoStartDock(var DragObject: TDragObject); override;
|
|
end;
|
|
|
|
TfrxDockToolBar = class(TToolBar)
|
|
protected
|
|
procedure DoStartDock(var DragObject: TDragObject); override;
|
|
end;
|
|
|
|
const
|
|
ColorFill = $ECDECE;
|
|
ColorClose = $606060;
|
|
|
|
type
|
|
|
|
TfrxDockTree = class(TDockTree, IfrxDPIAwareControl)
|
|
private
|
|
FFont:HFont;
|
|
FFontV:HFont;
|
|
FCurrentPPI: Integer;
|
|
HeadSize, ClosePadding, CaptionPadding, CloseWidth, TextHeight, TextHide: Integer;
|
|
FRectClose: TRect;
|
|
procedure DrawCaption(Canvas: TCanvas; ARect: TRect; Control: TControl);
|
|
procedure DrawRect(Canvas:TCanvas; R:TRect);
|
|
procedure DrawClose(Canvas:TCanvas; R:TRect);
|
|
procedure DoPPIChanged(aNewPPI: Integer);
|
|
procedure FreeFont;
|
|
protected
|
|
procedure PaintDockFrame(Canvas: TCanvas; Control: TControl; const ARect: TRect); override;
|
|
procedure AdjustDockRect(Control: TControl; var ARect: TRect); override;
|
|
procedure CreateCaptionFont(var Font,FontV:HFont);
|
|
{$IFDEF Delphi9}
|
|
function ZoneCaptionHitTest(const Zone: TDockZone; const MousePos: TPoint; var HTFlag: Integer): Boolean; override;
|
|
{$ELSE}
|
|
function HitTest(const MousePos: TPoint; out HTFlag: Integer): TControl; override;
|
|
{$ENDIF}
|
|
public
|
|
constructor Create(DockSite: TWinControl); override;
|
|
destructor Destroy; override;
|
|
end;
|
|
|
|
{$ELSE}
|
|
TfrxDockForm = TfrxBaseForm;
|
|
TfrxDockToolBar = class(TToolBar)
|
|
end;
|
|
{$ENDIF}
|
|
|
|
|
|
procedure frxSaveToolbarPosition(Ini: TCustomIniFile; t: TToolBar; FormPPIScale: Single);
|
|
procedure frxRestoreToolbarPosition(Ini: TCustomIniFile; t: TToolBar; CurrentFormPPI: Integer);
|
|
procedure frxSaveDock(Ini: TCustomIniFile; d: TfrxDockSite; FormPPIScale: Single);
|
|
procedure frxRestoreDock(Ini: TCustomIniFile; d: TfrxDockSite);
|
|
procedure frxSaveFormPosition(Ini: TCustomIniFile; f: TForm; FormPPIScale: Single);
|
|
procedure frxRestoreFormPosition(Ini: TCustomIniFile; f: TForm; FormPPIScale: Single);
|
|
|
|
|
|
{$IFDEF FPC}
|
|
//procedure Register;
|
|
{$ENDIF}
|
|
|
|
implementation
|
|
|
|
|
|
uses frxClass, frxUtils;
|
|
|
|
type
|
|
TWC = class (TWinControl)
|
|
end;
|
|
|
|
const
|
|
rsForm = 'Form5';
|
|
rsToolBar = 'ToolBar5';
|
|
rsDock = 'Dock5';
|
|
rsWidth = 'Width';
|
|
rsHeight = 'Height';
|
|
rsTop = 'Top';
|
|
rsLeft = 'Left';
|
|
rsFloat = 'Float';
|
|
rsVisible = 'Visible';
|
|
rsMaximized = 'Maximized';
|
|
rsData = 'Data';
|
|
rsSize = 'Size';
|
|
|
|
|
|
procedure frxSaveToolbarPosition(Ini: TCustomIniFile; t: TToolBar; FormPPIScale: Single);
|
|
var
|
|
X, Y: integer;
|
|
Name: String;
|
|
begin
|
|
Name := rsToolbar + '.' + t.Name;
|
|
Ini.WriteBool(Name, rsFloat, t.Floating);
|
|
Ini.WriteBool(Name, rsVisible, t.Visible);
|
|
if t.Floating then
|
|
begin
|
|
X := t.Parent.Left;
|
|
Y := t.Parent.Top;
|
|
end
|
|
else
|
|
begin
|
|
X := t.Left;
|
|
Y := t.Top;
|
|
end;
|
|
Ini.WriteInteger(Name, rsLeft, Round(X / FormPPIScale));
|
|
Ini.WriteInteger(Name, rsTop, Round(Y / FormPPIScale));
|
|
Ini.WriteInteger(Name, rsWidth, Round(t.Width / FormPPIScale));
|
|
Ini.WriteInteger(Name, rsHeight, Round(t.Height / FormPPIScale));
|
|
if t.Parent is TControlBar then
|
|
Ini.WriteString(Name, rsDock, t.Parent.Name);
|
|
end;
|
|
|
|
procedure frxRestoreToolbarPosition(Ini: TCustomIniFile; t: TToolBar; CurrentFormPPI: Integer);
|
|
var
|
|
DN: string;
|
|
NewDock: TControlBar;
|
|
Name: String;
|
|
X, Y, DX, DY: Integer;
|
|
begin
|
|
Name := rsToolbar + '.';
|
|
if CurrentFormPPI > frx_DefaultPPI then
|
|
Name := Name + IntToStr(CurrentFormPPI) + '.';
|
|
Name := Name + t.Name;
|
|
X := Ini.ReadInteger(Name, rsLeft, t.Left);
|
|
Y := Ini.ReadInteger(Name, rsTop, t.Top);
|
|
DX := Ini.ReadInteger(Name, rsWidth, t.Width);
|
|
DY := Ini.ReadInteger(Name, rsHeight, t.Height);
|
|
t.Visible := False;
|
|
if Ini.ReadBool(Name, rsFloat, False) then
|
|
t.ManualFloat(Rect(X, Y, X + DX, Y + DY))
|
|
else
|
|
begin
|
|
DN := Ini.ReadString(Name, rsDock, t.Parent.Name);
|
|
if (t.Owner <> nil) then
|
|
begin
|
|
NewDock := t.Owner.FindComponent(DN) as TControlBar;
|
|
if (NewDock <> nil) and (NewDock <> t.Parent) then
|
|
t.ManualDock(NewDock);
|
|
end;
|
|
t.SetBounds(X, Y, DX, DY);
|
|
end;
|
|
t.Visible := Ini.ReadBool(Name, rsVisible, True);
|
|
end;
|
|
|
|
procedure frxSaveDock(Ini: TCustomIniFile; d: TfrxDockSite; FormPPIScale: Single);
|
|
var
|
|
s: TMemoryStream;
|
|
begin
|
|
s := TMemoryStream.Create;
|
|
d.DockManager.SaveToStream(s);
|
|
{$IFDEF Delphi9}
|
|
Ini.WriteString(rsDock + '.' + d.Name, rsData + '2005', String(frxStreamToString(s)));
|
|
{$ELSE}
|
|
Ini.WriteString(rsDock + '.' + d.Name, rsData, frxStreamToString(s));
|
|
{$ENDIF}
|
|
Ini.WriteInteger(rsDock + '.' + d.Name, rsWidth, Round(d.Width / FormPPIScale));
|
|
Ini.WriteInteger(rsDock + '.' + d.Name, rsHeight, Round(d.Height / FormPPIScale));
|
|
Ini.WriteInteger(rsDock + '.' + d.Name, rsSize, d.SavedSize);
|
|
s.Free;
|
|
end;
|
|
|
|
procedure frxRestoreDock(Ini: TCustomIniFile; d: TfrxDockSite);
|
|
var
|
|
s: TStream;
|
|
sd: String;
|
|
function ReadAnsScale(pName: String; aValue: Integer): Integer;
|
|
begin
|
|
Result := Round(aValue / (d.CurrentPPI / frx_DefaultPPI));
|
|
Result := Ini.ReadInteger(rsDock + '.' + d.Name, pName, Result);
|
|
if Screen.PixelsPerInch >= d.CurrentPPI then
|
|
Result := Round(Result * (Screen.PixelsPerInch / frx_DefaultPPI));
|
|
end;
|
|
|
|
begin
|
|
s := TMemoryStream.Create;
|
|
try
|
|
{$IFDEF Delphi9}
|
|
sd := Ini.ReadString(rsDock + '.' + d.Name, rsData + '2005', '');
|
|
{$ELSE}
|
|
sd := Ini.ReadString(rsDock + '.' + d.Name, rsData, '');
|
|
{$ENDIF}
|
|
frxStringToStream(sd, s);
|
|
s.Position := 0;
|
|
if s.Size > 0 then
|
|
d.DockManager.LoadFromStream(s);
|
|
d.AutoSize := False;
|
|
d.Width := ReadAnsScale(rsWidth, d.Width);
|
|
d.Height := ReadAnsScale(rsHeight, d.Height);
|
|
d.SavedSize := Ini.ReadInteger(rsDock + '.' + d.Name, rsSize, 100);
|
|
d.AutoSize := True;
|
|
finally
|
|
s.Free;
|
|
end;
|
|
end;
|
|
|
|
procedure frxSaveFormPosition(Ini: TCustomIniFile; f: TForm; FormPPIScale: Single);
|
|
var
|
|
Name: String;
|
|
w, h: Integer;
|
|
begin
|
|
Name := rsForm + '.' + f.ClassName;
|
|
Ini.WriteInteger(Name, rsLeft, f.Left);
|
|
Ini.WriteInteger(Name, rsTop, f.Top);
|
|
w := Round(f.Width / FormPPIScale);
|
|
h := Round(f.Height / FormPPIScale);
|
|
Ini.WriteBool(Name, rsMaximized, f.WindowState = wsMaximized);
|
|
Ini.WriteBool(Name, rsVisible, f.Visible);
|
|
if f.HostDockSite <> nil then
|
|
Ini.WriteString(Name, rsDock, f.HostDockSite.Name)
|
|
else
|
|
Ini.WriteString(Name, rsDock, '');
|
|
Ini.WriteInteger(Name, rsWidth, w);
|
|
Ini.WriteInteger(Name, rsHeight, h);
|
|
end;
|
|
|
|
procedure frxRestoreFormPosition(Ini: TCustomIniFile; f: TForm; FormPPIScale: Single);
|
|
var
|
|
Name: String;
|
|
Dock: String;
|
|
cDock: TWinControl;
|
|
begin
|
|
Name := rsForm + '.' + f.ClassName;
|
|
if f.FormStyle <> fsMDIChild then
|
|
begin
|
|
if Ini.ReadBool(Name, rsMaximized, False) then
|
|
f.WindowState := wsMaximized
|
|
else
|
|
begin
|
|
f.SetBounds(Ini.ReadInteger(Name, rsLeft, f.Left),
|
|
Ini.ReadInteger(Name, rsTop, f.Top),
|
|
f.Width,
|
|
f.Height);
|
|
f.SetBounds(f.Left,
|
|
f.Top,
|
|
Round(Ini.ReadInteger(Name, rsWidth, f.Width) * FormPPIScale),
|
|
Round(Ini.ReadInteger(Name, rsHeight, f.Height) * FormPPIScale));
|
|
end;
|
|
end;
|
|
Dock := Ini.ReadString(Name, rsDock, '');
|
|
cDock := frxFindComponent(f.Owner, Dock) as TWinControl;
|
|
if cDock <> nil then
|
|
f.ManualDock(cDock);
|
|
if not (f is TfrxCustomDesigner) then
|
|
f.Visible := Ini.ReadBool(Name, rsVisible, True);
|
|
end;
|
|
|
|
|
|
{ TfrxTBPanel }
|
|
|
|
function GetAlign(al: TAlign): TAlign;
|
|
begin
|
|
if al in [alLeft, alRight] then
|
|
Result := alTop else
|
|
Result := alLeft;
|
|
end;
|
|
|
|
constructor TfrxTBPanel.Create(AOwner: TComponent);
|
|
begin
|
|
inherited Create(AOwner);
|
|
{$IFNDEF FPC}
|
|
Align := alLeft;
|
|
{$ENDIF}
|
|
Width := 8;
|
|
Height := 8;
|
|
BevelInner := bvNone;
|
|
BevelOuter := bvNone;
|
|
ControlStyle := ControlStyle{$IFDEF Delphi11} - [csParentBackground]{$ENDIF} + [csOpaque];
|
|
end;
|
|
|
|
procedure TfrxTBPanel.SetParent(AParent:TWinControl);
|
|
begin
|
|
inherited;
|
|
{$IFNDEF FPC}
|
|
if not (csDestroying in ComponentState) and (AParent <> nil) and (Parent is TPanel) then
|
|
Align := GetAlign(AParent.Parent.Align);
|
|
{$ENDIF}
|
|
end;
|
|
|
|
procedure TfrxTBPanel.Paint;
|
|
begin
|
|
{$IFDEF FPC}
|
|
inherited Paint;
|
|
{$ELSE}
|
|
{$IFDEF Delphi10}
|
|
inherited;
|
|
{$ELSE}
|
|
with Canvas do
|
|
begin
|
|
Brush.Color := clBtnFace;
|
|
FillRect(Rect(0, 0, Width, Height));
|
|
if csDesigning in ComponentState then
|
|
begin
|
|
Brush.Style := bsClear;
|
|
Pen.Style := psDot;
|
|
Pen.Color := clBtnShadow;
|
|
Rectangle(0, 0, Width - 1, Height - 1);
|
|
end;
|
|
end;
|
|
{$ENDIF}
|
|
{$ENDIF}
|
|
end;
|
|
|
|
|
|
{ TfrxDockSite }
|
|
|
|
type
|
|
THackControl = class(TControl);
|
|
|
|
TDockSplitter = class(TGraphicControl)
|
|
private
|
|
FDockSite: TfrxDockSite;
|
|
FDown: Boolean;
|
|
FCurrentPPI: Integer;
|
|
FRubberCountX: Integer;
|
|
FRubberCountY: Integer;
|
|
FRubberGapX: Integer;
|
|
FRubberGapY: Integer;
|
|
procedure DrawRubber(X, Y: Integer; Horizontal: Boolean);
|
|
protected
|
|
procedure SetParent(AParent: TWinControl); override;
|
|
function GetRubberGaps: TSize;
|
|
function GetRubberSize: TSize;
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
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;
|
|
procedure Paint; override;
|
|
property CurrentPPI: Integer read FCurrentPPI write FCurrentPPI;
|
|
end;
|
|
|
|
|
|
{ TDockSplitter }
|
|
|
|
constructor TDockSplitter.Create(AOwner: TComponent);
|
|
begin
|
|
inherited;
|
|
FDockSite := TfrxDockSite(AOwner);
|
|
FCurrentPPI := Screen.PixelsPerInch;
|
|
FRubberCountX := 1;
|
|
FRubberCountY := 6;
|
|
FRubberGapX := 3;
|
|
FRubberGapY := 3;
|
|
end;
|
|
|
|
procedure TDockSplitter.DrawRubber(X, Y: Integer; Horizontal: Boolean);
|
|
var
|
|
dx, dy, i, j: Integer;
|
|
nScale: Single;
|
|
Gaps: TSize;
|
|
begin
|
|
Gaps := GetRubberGaps;
|
|
if Horizontal then
|
|
Inc(X, Gaps.cy)
|
|
else
|
|
Inc(Y, Gaps.cy);
|
|
nScale := CurrentPPI / frx_DefaultPPI;
|
|
for j := 0 to FRubberCountX - 1 do
|
|
begin
|
|
dx := X;
|
|
dy := Y;
|
|
for i := 0 to FRubberCountY - 1 do
|
|
begin
|
|
if nScale = 1 then
|
|
begin
|
|
Canvas.Pixels[dx, dy] := clWhite;
|
|
Canvas.Pixels[dx + 1, dy] := clGray;
|
|
Canvas.Pixels[dx, dy + 1] := clGray;
|
|
Canvas.Pixels[dx + 1, dy + 1] := clGray;
|
|
end
|
|
else
|
|
begin
|
|
Canvas.Pen.Style := psClear;
|
|
Canvas.Brush.Color := clGray;
|
|
Canvas.FillRect(Rect(dx, dy, dx + Round(nScale * 2), dy + Round(nScale * 2)));
|
|
Canvas.Brush.Color := clWhite;
|
|
Canvas.FillRect(Rect(dx, dy, dx + Round(nScale), dy + Round(nScale)));
|
|
end;
|
|
|
|
if Horizontal then
|
|
Inc(dx, Round(nScale * 2 + Gaps.cy))
|
|
else
|
|
Inc(dy, Round(nScale * 2 + Gaps.cy));
|
|
end;
|
|
if Horizontal then
|
|
Inc(Y, Round(nScale * 2 + Gaps.cx))
|
|
else
|
|
Inc(X, Round(nScale * 2 + Gaps.cx));
|
|
end;
|
|
end;
|
|
|
|
function TDockSplitter.GetRubberGaps: TSize;
|
|
begin
|
|
Result.cx := FRubberGapX;
|
|
Result.cy := FRubberGapY;
|
|
end;
|
|
|
|
function TDockSplitter.GetRubberSize: TSize;
|
|
var
|
|
nScale: Single;
|
|
Gaps: TSize;
|
|
begin
|
|
Gaps := GetRubberGaps;
|
|
nScale := CurrentPPI / frx_DefaultPPI * 2;
|
|
Result.cx := Round((Gaps.cx + nScale) * FRubberCountX) - Gaps.cx;
|
|
Result.cy := Round((Gaps.cy + nScale) * FRubberCountY) + Gaps.cy + Round(CurrentPPI / frx_DefaultPPI);
|
|
end;
|
|
|
|
procedure TDockSplitter.MouseDown(Button: TMouseButton; Shift: TShiftState;
|
|
X, Y: Integer);
|
|
begin
|
|
inherited;
|
|
FDown := True;
|
|
|
|
if Cursor = crHandPoint then
|
|
with FDockSite do
|
|
begin
|
|
if Align in [alLeft, alRight] then
|
|
begin
|
|
if Width = 0 then
|
|
begin
|
|
AutoSize := False;
|
|
Width := SavedSize;
|
|
if Align = alLeft then
|
|
Self.Left := Left + Width
|
|
else
|
|
Self.Left := Left - Self.Width;
|
|
AutoSize := True;
|
|
end
|
|
else
|
|
begin
|
|
AutoSize := False;
|
|
SavedSize := Width;
|
|
Width := 0;
|
|
end;
|
|
end
|
|
else
|
|
begin
|
|
if Height = 0 then
|
|
begin
|
|
AutoSize := False;
|
|
Height := SavedSize;
|
|
if Align = alTop then
|
|
Self.Top := Top + Height
|
|
else
|
|
Self.Top := Top - Self.Height;
|
|
AutoSize := True;
|
|
end
|
|
else
|
|
begin
|
|
AutoSize := False;
|
|
SavedSize := Height;
|
|
Height := 0;
|
|
end;
|
|
end;
|
|
FDown := False;
|
|
end;
|
|
end;
|
|
|
|
procedure TDockSplitter.MouseMove(Shift: TShiftState; X, Y: Integer);
|
|
var
|
|
mid: Integer;
|
|
{$IFDEF FPC}
|
|
i: Integer;
|
|
{$ENDIF}
|
|
begin
|
|
inherited;
|
|
|
|
if Align in [alLeft, alRight] then
|
|
begin
|
|
mid := Height div 2;
|
|
if (Y > mid - 20) and (Y < mid + 20) then
|
|
Cursor := crHandPoint
|
|
else
|
|
Cursor := crHSplit;
|
|
end
|
|
else
|
|
begin
|
|
mid := Width div 2;
|
|
if (X > mid - 20) and (X < mid + 20) then
|
|
Cursor := crHandPoint
|
|
else
|
|
Cursor := crVSplit;
|
|
end;
|
|
|
|
if FDown then
|
|
with FDockSite do
|
|
begin
|
|
{$IFDEF FPC}
|
|
{$warning hardcoded logic}
|
|
for i := 0 to FDockSite.ControlCount - 1 do
|
|
begin
|
|
if FDockSite.Controls[i] is TCustomForm then
|
|
begin
|
|
if FDockSite.Controls[i].ClassName = 'TfrxReportTreeForm' then
|
|
FDockSite.Controls[i].Align := alTop
|
|
else
|
|
FDockSite.Controls[i].Align := alClient;
|
|
end;
|
|
end;
|
|
{$ENDIF}
|
|
|
|
AutoSize := False;
|
|
case Align of
|
|
alLeft:
|
|
Width := Width + X;
|
|
alRight:
|
|
Width := Width - X;
|
|
alTop:
|
|
Height := Height + Y;
|
|
alBottom:
|
|
Height := Height - Y;
|
|
end;
|
|
{$IFNDEF FPC}
|
|
AutoSize := True;
|
|
{$ENDIF}
|
|
end;
|
|
end;
|
|
|
|
procedure TDockSplitter.MouseUp(Button: TMouseButton; Shift: TShiftState;
|
|
X, Y: Integer);
|
|
begin
|
|
inherited;
|
|
FDown := False;
|
|
end;
|
|
|
|
procedure TDockSplitter.Paint;
|
|
var
|
|
mid, x, x1, y, y1: Integer;
|
|
lScale: Single;
|
|
sz: TSize;
|
|
begin
|
|
inherited;
|
|
sz := GetRubberSize;
|
|
with Canvas do
|
|
begin
|
|
if Align in [alLeft, alRight] then
|
|
mid := Self.Height div 2
|
|
else
|
|
mid := Self.Width div 2;
|
|
lScale := CurrentPPI / frx_DefaultPPI;
|
|
y := mid - sz.cy div 2;
|
|
x1 := Round(6 * lScale);
|
|
y1 := mid + sz.cy div 2;
|
|
x := Round(2 * lScale);
|
|
Brush.Color := clScrollBar;// //$C0D0D0;
|
|
if Align in [alLeft, alRight] then
|
|
begin
|
|
FillRect(Rect(0, y, x1, y1));
|
|
DrawRubber(x, y, False);
|
|
end
|
|
else
|
|
begin
|
|
FillRect(Rect(y, 0, y1, x1));
|
|
DrawRubber(y, x, True);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure TDockSplitter.SetParent(AParent: TWinControl);
|
|
begin
|
|
inherited;
|
|
if AParent is TfrxDPIAwarePanel then
|
|
FCurrentPPI := TfrxDPIAwarePanel(AParent).CurrentPPI
|
|
else
|
|
FCurrentPPI := Screen.PixelsPerInch;
|
|
end;
|
|
|
|
{ TfrxDockSite }
|
|
|
|
constructor TfrxDockSite.Create(AOwner: TComponent);
|
|
begin
|
|
inherited;
|
|
if csDesigning in ComponentState then
|
|
DockSite := True;
|
|
Align := alLeft;
|
|
Caption := ' ';
|
|
AutoSize := True;
|
|
BevelInner := bvNone;
|
|
BevelOuter := bvNone;
|
|
Width := 10;
|
|
Height := 10;
|
|
|
|
FSplitter := TDockSplitter.Create(Self);
|
|
FSplitter.Visible := False;
|
|
end;
|
|
|
|
procedure TfrxDockSite.SetParent(AParent: TWinControl);
|
|
begin
|
|
inherited;
|
|
if Parent <> nil then
|
|
FSplitter.Parent := Parent;
|
|
end;
|
|
|
|
procedure TfrxDockSite.UpdateAlign;
|
|
begin
|
|
case Align of
|
|
alLeft:
|
|
begin
|
|
FSplitter.Width := Round(6 * CurrentPPI / frx_DefaultPPI);
|
|
FSplitter.Left := Left + Width + 6;
|
|
end;
|
|
alRight:
|
|
begin
|
|
FSplitter.Width := Round(6 * CurrentPPI / frx_DefaultPPI);
|
|
FSplitter.Left := Left - 6;
|
|
end;
|
|
alTop:
|
|
begin
|
|
FSplitter.Height := Round(6 * CurrentPPI / frx_DefaultPPI);
|
|
FSplitter.Top := Top + Height + 6;
|
|
end;
|
|
alBottom:
|
|
begin
|
|
FSplitter.Height := Round(6 * CurrentPPI / frx_DefaultPPI);
|
|
FSplitter.Top := Top - 6;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TfrxDockSite.VisibleChanging;
|
|
begin
|
|
inherited;
|
|
FSplitter.Visible := not Visible;
|
|
end;
|
|
|
|
procedure TfrxDockSite.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
|
|
begin
|
|
inherited;
|
|
if {$IFDEF FPC}HandleAllocated and {$ENDIF} (FSplitter <> nil) then
|
|
if Align <> FSplitter.Align then
|
|
begin
|
|
UpdateAlign;
|
|
FSplitter.Align := Align;
|
|
end;
|
|
end;
|
|
|
|
procedure TfrxDockSite.DockDrop(Source: TDragDockObject; X, Y: Integer);
|
|
begin
|
|
{attach dock only to owner, need for MDI designer}
|
|
if (TopParentWin <> nil) and (Source.Control.Owner <> nil) and (Source.Control.Owner.Name <> TopParentWin.Name) then
|
|
exit;
|
|
inherited;
|
|
if Align in [alLeft, alRight] then
|
|
begin
|
|
if Width < FPanelSize then
|
|
Source.Control.Width := FPanelSize;
|
|
end
|
|
else
|
|
begin
|
|
if Height < FPanelSize then
|
|
Source.Control.Height := FPanelSize;
|
|
end;
|
|
FSplitter.Show;
|
|
end;
|
|
|
|
procedure TfrxDockSite.DockOver(Source: TDragDockObject; X, Y: Integer;
|
|
State: TDragState; var Accept: Boolean);
|
|
begin
|
|
{attach dock only to owner, need for MDI designer}
|
|
if (TopParentWin <> nil) and (Source.Control.Owner <> nil) and (Source.Control.Owner.Name <> TopParentWin.Name) then
|
|
exit;
|
|
inherited;
|
|
if Align in [alLeft, alRight] then
|
|
FPanelSize := Source.Control.Width
|
|
else
|
|
FPanelSize := Source.Control.Height;
|
|
end;
|
|
|
|
procedure TfrxDockSite.DoPPIChanged(aNewPPI: Integer);
|
|
var
|
|
DPIControl: IfrxDPIAwareControl;
|
|
begin
|
|
inherited;
|
|
if Assigned(FSplitter) then
|
|
TDockSplitter(FSplitter).CurrentPPI := aNewPPI;
|
|
if Assigned(DockManager) and Supports(DockManager, IfrxDPIAwareControl, DPIControl) then
|
|
DPIControl.DoPPIChanged(aNewPPI);
|
|
end;
|
|
|
|
{$IFNDEF FPC}
|
|
function TfrxDockSite.CreateDockManager: IDockManager;
|
|
begin
|
|
if (DockManager = nil) and DockSite and UseDockManager then
|
|
begin
|
|
//case DockTreeKind of
|
|
Result := TfrxDockTree.Create(Self);
|
|
end else
|
|
Result := DockManager;
|
|
DoubleBuffered := DoubleBuffered or (Result <> nil);
|
|
end;
|
|
{$ENDIF}
|
|
|
|
function TfrxDockSite.DoUnDock(NewTarget: TWinControl; Client: TControl
|
|
{$IFDEF FPC}; KeepDockSiteSize: Boolean = true{$ENDIF}): Boolean;
|
|
begin
|
|
Result := False;
|
|
if (NewTarget <> nil) and (NewTarget.Owner <> Self.Owner) then
|
|
exit;
|
|
Result := inherited DoUnDock(NewTarget, Client);
|
|
if DockClientCount <= 1 then
|
|
FSplitter.Hide;
|
|
end;
|
|
|
|
procedure TfrxDockSite.ReloadDockedControl(const AControlName: string;
|
|
var AControl: TControl);
|
|
var
|
|
I: Integer;
|
|
Com: TComponent;
|
|
begin
|
|
{search dock window in designer component list, need for MDI or multi-window designer}
|
|
if (AControlName <> '') and (FTopParentWin.ComponentCount > 0) then
|
|
for I := 0 to FTopParentWin.ComponentCount - 1 do
|
|
begin
|
|
Com := FTopParentWin.Components[I];
|
|
if Pos(AControlName, Com.Name) > 0 then
|
|
begin
|
|
AControl := Com as TControl;
|
|
exit;
|
|
end;
|
|
end;
|
|
AControl := FindGlobalComponent(AControlName) as TControl;
|
|
end;
|
|
|
|
{$IFNDEF FPC}
|
|
{ TBlueForm }
|
|
|
|
procedure TBlueForm.CreateParams(var Params: TCreateParams);
|
|
begin
|
|
inherited CreateParams(Params);
|
|
Params.ExStyle := Params.ExStyle or WS_EX_TRANSPARENT;
|
|
end;
|
|
|
|
{ TfrxDragDockObject }
|
|
|
|
constructor TfrxDragDockObject.Create(AControl: TControl);
|
|
begin
|
|
inherited;
|
|
BlueForm := TBlueForm.CreateNew(nil);
|
|
BlueForm.Visible := False;
|
|
BlueForm.Color := clHighlight;
|
|
BlueForm.AlphaBlend := True;
|
|
BlueForm.AlphaBlendValue := 140;
|
|
BlueForm.BorderIcons := [];
|
|
BlueForm.BorderStyle := bsNone;
|
|
BlueForm.FormStyle := fsStayOnTop;
|
|
BlueForm.BoundsRect := Rect(0, 0, 0, 0);
|
|
end;
|
|
|
|
procedure TfrxDragDockObject.DrawDragDockImage;
|
|
var
|
|
DockRect: TRect;
|
|
const
|
|
Padd = 10;
|
|
begin
|
|
BlueForm.Visible := True;
|
|
DockRect := TDragDockObject(Self).DockRect;
|
|
if (DockRect.Right - DockRect.Left <= 0) then
|
|
begin
|
|
DockRect.Left := DockRect.Left - Padd;
|
|
DockRect.Right := DockRect.Right + Padd;
|
|
end;
|
|
if (DockRect.Bottom - DockRect.Top <= 0) then
|
|
begin
|
|
DockRect.Top := DockRect.Top - Padd;
|
|
DockRect.Bottom := DockRect.Bottom + Padd;
|
|
end;
|
|
BlueForm.BoundsRect := DockRect;
|
|
end;
|
|
|
|
procedure TfrxDragDockObject.EraseDragDockImage;
|
|
begin
|
|
end;
|
|
|
|
destructor TfrxDragDockObject.Destroy;
|
|
begin
|
|
inherited;
|
|
BlueForm.Free;
|
|
end;
|
|
|
|
{ TfrxDockForm }
|
|
|
|
procedure TfrxDockForm.DoStartDock(var DragObject: TDragObject);
|
|
begin
|
|
inherited;
|
|
if DragObject = nil then
|
|
begin
|
|
DragObject := TDragDockObject(TfrxDragDockObject.Create(TControl(Self)));
|
|
end;
|
|
end;
|
|
|
|
{ TfrxDockToolBar }
|
|
|
|
procedure TfrxDockToolBar.DoStartDock(var DragObject: TDragObject);
|
|
begin
|
|
inherited;
|
|
if DragObject = nil then
|
|
begin
|
|
DragObject := TDragDockObject(TfrxDragDockObject.Create(TControl(Self)));
|
|
end;
|
|
end;
|
|
|
|
{ TfrxDockTree }
|
|
|
|
destructor TfrxDockTree.Destroy;
|
|
begin
|
|
inherited;
|
|
FreeFont;
|
|
end;
|
|
|
|
procedure TfrxDockTree.DoPPIChanged(aNewPPI: Integer);
|
|
var
|
|
Scale: Double;
|
|
begin
|
|
if FCurrentPPI = aNewPPI then Exit;
|
|
FreeFont;
|
|
Scale := aNewPPI / frx_DefaultPPI;
|
|
HeadSize := Round(20 * Scale);
|
|
ClosePadding := Round(6 * Scale);
|
|
CaptionPadding := Round(4 * Scale);
|
|
CloseWidth := Round(2 * Scale);
|
|
TextHeight := Round(-13 * Scale);
|
|
TextHide := Round(10 * Scale);
|
|
FCurrentPPI := aNewPPI;
|
|
end;
|
|
|
|
constructor TfrxDockTree.Create(DockSite: TWinControl);
|
|
begin
|
|
inherited;
|
|
DoPPIChanged(Screen.PixelsPerInch);
|
|
end;
|
|
|
|
procedure TfrxDockTree.CreateCaptionFont(var Font,FontV:HFont);
|
|
var
|
|
FontInfo: tagLOGFONTW;
|
|
NonClientMetrics: tagNONCLIENTMETRICSW;
|
|
begin
|
|
if Font = 0 then
|
|
begin
|
|
fillchar(NonClientMetrics, SizeOf(NonClientMetrics), 0);
|
|
NonClientMetrics.cbSize := SizeOf(NonClientMetrics);
|
|
if SystemParametersInfoW(SPI_GETNONCLIENTMETRICS, 0, @NonClientMetrics, 0) then
|
|
FontInfo := NonClientMetrics.lfStatusFont;
|
|
FontInfo.lfHeight := TextHeight;
|
|
FontInfo.lfWeight := FW_NORMAL;
|
|
Font := CreateFontIndirectW(FontInfo);
|
|
FontInfo.lfEscapement := 900;
|
|
FontV := CreateFontIndirectW(FontInfo);
|
|
end;
|
|
end;
|
|
|
|
{$IFDEF Delphi9}
|
|
function TfrxDockTree.ZoneCaptionHitTest(const Zone: TDockZone; const MousePos: TPoint; var HTFlag: Integer): Boolean;
|
|
var
|
|
ZoneTop, ZoneLeft: Integer;
|
|
begin
|
|
Result := False;
|
|
ZoneTop := Zone.Top;
|
|
ZoneLeft := Zone.Left;
|
|
if not (DockSite.Align in [alTop, alBottom]) then
|
|
begin
|
|
if (MousePos.Y >= ZoneTop) and (MousePos.Y <= ZoneTop + HeadSize) and
|
|
(MousePos.X >= ZoneLeft) and (MousePos.X <= ZoneLeft + Zone.Width) then
|
|
begin
|
|
Result := True;
|
|
with Zone.ChildControl do
|
|
if PtInRect(FRectClose, MousePos) then
|
|
HTFlag := HTCLOSE
|
|
else
|
|
HTFlag := HTCAPTION;
|
|
end;
|
|
end
|
|
else
|
|
begin
|
|
if (MousePos.X >= ZoneLeft) and (MousePos.X <= ZoneLeft + HeadSize) and
|
|
(MousePos.Y >= ZoneTop) and (MousePos.Y <= ZoneTop + Zone.Height) then
|
|
begin
|
|
Result := True;
|
|
if PtInRect(FRectClose, MousePos) then
|
|
HTFlag := HTCLOSE
|
|
else
|
|
HTFlag := HTCAPTION;
|
|
end;
|
|
end;
|
|
end;
|
|
{$ELSE}
|
|
function TfrxDockTree.HitTest(const MousePos: TPoint; out HTFlag: Integer): TControl;
|
|
begin
|
|
Result := inherited HitTest(MousePos, HTFlag);
|
|
if not (DockSite.Align in [alTop, alBottom]) then
|
|
if PtInRect(FRectClose, MousePos) then
|
|
HTFlag := HTCLOSE;
|
|
end;
|
|
{$ENDIF}
|
|
|
|
procedure TfrxDockTree.AdjustDockRect(Control: TControl; var ARect: TRect);
|
|
begin
|
|
if not (DockSite.Align in [alTop, alBottom]) then
|
|
Inc(ARect.Top, HeadSize)
|
|
else
|
|
Inc(ARect.Left, HeadSize)
|
|
end;
|
|
|
|
procedure TfrxDockTree.DrawCaption(Canvas:TCanvas; ARect:TRect; Control:TControl);
|
|
var
|
|
Cap: String;
|
|
OldFont: HFont;
|
|
DC: HDC;
|
|
R: TRect;
|
|
begin
|
|
if (Control is TWinControl) then
|
|
begin
|
|
Cap := TWC(Control).Text;
|
|
if (Cap <> '') and (Abs(ARect.Right - ARect.Left) > TextHide) and (Abs(ARect.Bottom - ARect.top) > TextHide) then
|
|
begin
|
|
if fFont = 0 then
|
|
CreateCaptionFont(FFont, FFontV);
|
|
if fFont <> 0 then
|
|
begin
|
|
Canvas.Lock;
|
|
try
|
|
DC := Canvas.Handle;
|
|
SetBkMode(DC, TRANSPARENT);
|
|
if (DockSite.Align in [alTop, alBottom]) then
|
|
begin
|
|
OldFont := SelectObject(DC, FFontV);
|
|
try
|
|
R := Rect(ARect.Left, ARect.Bottom, ARect.Left + Abs(ARect.Bottom-ARect.Top), ARect.Top);
|
|
Windows.DrawText(DC, PChar(Cap), Length(Cap), R, DT_END_ELLIPSIS or DT_SINGLELINE or DT_NOCLIP);
|
|
finally
|
|
SelectObject(DC, OldFont);
|
|
end;
|
|
end else
|
|
begin
|
|
OldFont := SelectObject(DC, fFont);
|
|
try
|
|
Windows.DrawText(DC, PChar(Cap), Length(Cap), ARect, DT_END_ELLIPSIS or DT_SINGLELINE);
|
|
finally
|
|
SelectObject(DC, OldFont);
|
|
end;
|
|
end;
|
|
finally
|
|
Canvas.Unlock;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TfrxDockTree.DrawRect(Canvas:TCanvas; R:TRect);
|
|
begin
|
|
if ((R.Right - R.Left) > 0) and ((R.Bottom - R.top) > 0) then
|
|
begin
|
|
Canvas.Brush.Color := ColorFill;
|
|
Canvas.FillRect(R);
|
|
end;
|
|
end;
|
|
|
|
procedure TfrxDockTree.FreeFont;
|
|
begin
|
|
if FFont <> 0 then DeleteObject(fFont);
|
|
if FFontV <> 0 then DeleteObject(fFontV);
|
|
FFont := 0;
|
|
FFontV := FFont;
|
|
end;
|
|
|
|
procedure TfrxDockTree.DrawClose(Canvas:TCanvas; R:TRect);
|
|
begin
|
|
Canvas.Pen.Color := ColorClose;
|
|
Canvas.Pen.Width := CloseWidth;
|
|
if ((R.Right - R.Left) mod 2) = 1 then
|
|
R.Right := R.Right - 1;
|
|
if ((R.Bottom - R.Top) mod 2) = 1 then
|
|
R.Bottom := R.Bottom - 1;
|
|
FRectClose := R;
|
|
Canvas.MoveTo(R.Left, R.Top);
|
|
Canvas.LineTo(R.right, R.Bottom);
|
|
Canvas.MoveTo(R.Left, R.Bottom);
|
|
Canvas.LineTo(R.Right, R.Top);
|
|
end;
|
|
|
|
procedure TfrxDockTree.PaintDockFrame(Canvas: TCanvas; Control: TControl; const ARect: TRect);
|
|
var
|
|
CloseRect: TRect;
|
|
begin
|
|
//case DockTreeKind of
|
|
if (DockSite.Align in [alTop, alBottom]) then
|
|
begin
|
|
DrawRect(Canvas, Rect(ARect.Left, ARect.Top, ARect.Left + HeadSize, ARect.Bottom));
|
|
CloseRect := Rect(ARect.Left + ClosePadding, ARect.Top + ClosePadding,
|
|
ARect.Left + HeadSize - ClosePadding, ARect.Top + HeadSize - ClosePadding);
|
|
DrawClose(Canvas, CloseRect);
|
|
DrawCaption(Canvas, Rect(ARect.Left, ARect.Top + CaptionPadding + (CloseRect.Right - CloseRect.Left) * 2,
|
|
ARect.Left + HeadSize, ARect.Bottom - CaptionPadding), Control);
|
|
end else
|
|
begin
|
|
DrawRect(Canvas, Rect(ARect.Left, ARect.Top, ARect.Right, ARect.Top + HeadSize));
|
|
CloseRect := Rect(ARect.Right - HeadSize + ClosePadding, ARect.Top + ClosePadding,
|
|
ARect.Right - ClosePadding, ARect.Top + HeadSize - ClosePadding);
|
|
DrawClose(Canvas, CloseRect);
|
|
DrawCaption(Canvas, Rect(ARect.Left + CaptionPadding, ARect.Top,
|
|
ARect.Right - (CloseRect.Right - CloseRect.Left) * 2, ARect.Top + HeadSize), Control);
|
|
end;
|
|
end;
|
|
|
|
{$ENDIF}
|
|
|
|
{$IFDEF FPC}
|
|
{procedure RegisterUnitfrxDock;
|
|
begin
|
|
RegisterComponents('Fast Report 6',[TfrxTBPanel, TfrxDockSite
|
|
]);
|
|
end;
|
|
|
|
procedure Register;
|
|
begin
|
|
RegisterUnit('frxDock',@RegisterUnitfrxDock);
|
|
end;}
|
|
{$ENDIF}
|
|
|
|
end.
|