paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-04-07 06:38:06 +02:00
Code Issues Packages Projects Releases Wiki Activity

dockmanager example: back to the roots

Browse Source 
git-svn-id: trunk@20028 -
This commit is contained in:
dodi 2009-05-18 15:28:04 +00:00
parent 8ed7281c00
commit fa5fca7dd1
5 changed files with 590 additions and 686 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitattributes vendored
View File

@ -2170,7 +2170,6 @@ examples/docking/unit1.pas svneol=native#text/pascal
examples/dockmanager/easytree/BUGS.txt svneol=native#text/plain
examples/dockmanager/easytree/README.txt svneol=native#text/plain
examples/dockmanager/easytree/easy_dock_images.lrs svneol=native#text/plain
examples/dockmanager/easytree/easydockhelpers.pas svneol=native#text/plain
examples/dockmanager/easytree/easydocking.lpi svneol=native#text/plain
examples/dockmanager/easytree/easydocking.lpr svneol=native#text/plain
examples/dockmanager/easytree/easydocksite.pas svneol=native#text/plain
@ -2183,6 +2182,7 @@ examples/dockmanager/easytree/fmain.pas svneol=native#text/plain
examples/dockmanager/easytree/ftree.lfm svneol=native#text/plain
examples/dockmanager/easytree/ftree.lrs svneol=native#text/plain
examples/dockmanager/easytree/ftree.pas svneol=native#text/plain
examples/dockmanager/easytree/zoneheader.inc svneol=native#text/pascal
examples/dragimagelist/project1.lpi svneol=native#text/plain
examples/dragimagelist/project1.lpr svneol=native#text/pascal
examples/dragimagelist/readme.txt svneol=native#text/plain

466
examples/dockmanager/easytree/easydockhelpers.pas
View File

@ -1,466 +0,0 @@
unit EasyDockHelpers;
(* Defines helper classes for TEasyDockSite.
Parts stolen from LDockTree...
- Zone header class
- Basic zone class, used in painting the header
The zone header class may become a component, derived e.g. from TSplitter.
It paints all parts of the zone header.
Support for an (experimental) Restore button is conditionally available,
but it deserves a definition of its purpose.
Hiding and unhiding controls requires docking manager notifications in the LCL!
*)
{$mode objfpc}{$H+}
{.$DEFINE restore} //use restore button?
interface
uses
Types, LCLType, Controls, Graphics, ExtCtrls;
type
TEasyZonePart =
(
zpNowhere, // not in any zone
zpClient, // on client control
zpAll, // total header rect
zpCaption, // header caption
zpSizer, // splitter/sizer
{$IFDEF restore}
zpRestoreButton, // header restore button
{$ENDIF}
zpCloseButton // header close button
);
//minimal zone interface, used by TEasyDockHeader and other helper classes
{ TCustomDockZone }
TCustomDockZone = class
protected //deserve direct access in derived classes
FChildControl: TControl;
function GetHeaderSize: integer; virtual;
function GetHandle: HWND; virtual; abstract;
function GetRectOfPart(APart: TEasyZonePart): TRect;
public
function GetBounds: TRect; virtual;
function HasSizer: boolean; virtual;
end;
{ TEasyDockHeader }
// maybe once it will be control, so now better to move all related to header things to class
TEasyDockHeader = class
public
HeaderSize: integer;
//state last drawn
MouseZone: TCustomDockZone;
MouseDown: boolean;
MousePart: TEasyZonePart;
PartRect: TRect;
public
constructor Create;
class function GetRectOfPart(AHeaderRect: TRect; AOrientation: TDockOrientation; APart: TEasyZonePart; HasSplitter: boolean): TRect; virtual;
function FindPart(AZone: TCustomDockZone; MousePos: TPoint; fButtonDown: boolean): TEasyZonePart;
procedure Draw(AZone: TCustomDockZone; ACanvas: TCanvas; ACaption: string; const MousePos: TPoint); virtual;
end;
TEasySplitter = TCustomSplitter;
const
{$IFDEF restore}
HeaderButtons = [zpCloseButton, zpRestoreButton];
{$ELSE}
HeaderButtons = [zpCloseButton];
{$ENDIF}
implementation
uses
Classes, SysUtils, Themes, LResources, LCLIntf, LCLProc;
type
{
TDockHeaderMouseState = record
Rect: TRect;
IsMouseDown: Boolean;
end;
}
TDockHeaderImageKind =
(
dhiRestore,
dhiClose
);
TDockHeaderImages = array[TDockHeaderImageKind] of TCustomBitmap;
const
DockHeaderImageNames: array[TDockHeaderImageKind] of String =
(
{ dhiRestore } 'easy_dock_restore',
{ dhiClose } 'easy_dock_close'
);
var
DockBtnImages: TDockHeaderImages;
procedure CreateDockHeaderImages;
var
ImageKind: TDockHeaderImageKind;
begin
for ImageKind := Low(TDockHeaderImageKind) to High(TDockHeaderImageKind) do
DockBtnImages[ImageKind] := CreateBitmapFromLazarusResource(DockHeaderImageNames[ImageKind]);
end;
procedure DestroyDockHeaderImages;
var
ImageKind: TDockHeaderImageKind;
begin
for ImageKind := Low(TDockHeaderImageKind) to High(TDockHeaderImageKind) do
FreeAndNil(DockBtnImages[ImageKind]);
end;
{ TEasyDockHeader }
type
TZonePartMap = record
dTop, dBottom, dLeft, dRight: integer;
end;
const //zone decoration sizes
dSizer = 4;
dBorder = 2; //frame and inner bevel
dDist = 1; //button distance
dButton = 14;
dHeader = dButton + 2*dBorder; // 22 - dSizer; //splitter outside header!
(* Zone part map.
In portrait mode (header on top), the zone rectangle is adjusted according
to the given offsets. In landscape mode (header on the left), the offsets
have to be applied to the rotated coordinates.
Positive offsets mean self-relative adjustment, towards the opposite edge.
This operation has highest precedence.
Negative offsets mean adjustment relative to the adjusted opposite edge.
The map reflects new splitter placement (past client area),
and no restore button.
*)
HeaderPartMap: array[TEasyZonePart] of TZonePartMap = (
(), //zpNowhere, // not in any zone
(dTop:dHeader; dBottom:0), //zpClient, // on client control
(dTop:0; dBottom:-dHeader), //zpAll, // total header rect
(dTop:dBorder; dBottom:-dButton; dLeft:dBorder; dRight:dBorder+dButton), //zpCaption, // header caption
(dTop:-dSizer), //zpSizer, // splitter/sizer
{$IFDEF restore}
(...), //zpRestoreButton, // header restore button
{$ENDIF}
//(dTop:dBorder; dBottom:-dHeader; dLeft:-(dBorder+dButton); dRight:dBorder) //zpCloseButton // header close button
(dTop:dBorder; dBottom:-dButton; dLeft:-dButton; dRight:dBorder) //zpCloseButton // header close button
);
constructor TEasyDockHeader.Create;
procedure dump;
var
r, r2: TRect;
begin
r := Rect(0, 0, 200, HeaderSize); //LTBR
r2 := GetRectOfPart(r, doVertical, zpCaption, True);
DebugLn('%s (%d,%d)-(%d,%d)', ['caption', r2.Top, r2.Left, r2.Bottom, r2.Right]);
r2 := GetRectOfPart(r, doVertical, zpCloseButton, true);
DebugLn('%s (%d,%d)-(%d,%d)', ['closer ', r2.Top, r2.Left, r2.Bottom, r2.Right]);
r2 := GetRectOfPart(r, doVertical, zpSizer, true);
DebugLn('%s (%d,%d)-(%d,%d)', ['sizer ', r2.Top, r2.Left, r2.Bottom, r2.Right]);
end;
begin
HeaderSize := dHeader; //some meaningful value?
//debug
//dump;
end;
class function TEasyDockHeader.GetRectOfPart(AHeaderRect: TRect; AOrientation: TDockOrientation;
APart: TEasyZonePart; HasSplitter: boolean): TRect;
begin
(* AHeaderRect is (must be) TLBR zone rectangle, on input.
*)
if (APart = zpNowhere) or ((APart = zpSizer) and not HasSplitter) then begin
Result := Rect(0,0,0,0);
exit;
end;
Result := AHeaderRect;
with HeaderPartMap[APart] do begin
if AOrientation = doVertical then begin //portrait
if dTop > 0 then
inc(Result.Top, dTop);
if dBottom > 0 then
dec(Result.Bottom, dBottom)
else if dBottom < 0 then
Result.Bottom := Result.Top - dBottom;
if dTop < 0 then
Result.Top := Result.Bottom + dTop;
if dLeft > 0 then
inc(Result.Left, dLeft);
if dRight > 0 then
dec(Result.Right, dRight)
else if dRight < 0 then
Result.Right := Result.Left + dRight;
if dLeft < 0 then
Result.Left := Result.Right + dLeft;
//handle client w/o splitter
if (APart = zpClient) and HasSplitter then
dec(Result.Bottom, dSizer);
end else begin //landscape
if dTop > 0 then
inc(Result.Left, dTop);
if dBottom > 0 then
dec(Result.Right, dBottom)
else if dBottom < 0 then
Result.Right := Result.Left - dBottom;
if dTop < 0 then
Result.Left := Result.Right + dTop;
if dLeft > 0 then
dec(Result.Bottom, dLeft);
if dRight > 0 then
inc(Result.Top, dRight)
else if dRight < 0 then
Result.Top := Result.Bottom + dRight;
if dLeft < 0 then
Result.Bottom := Result.Top - dLeft;
//handle client w/o splitter
if (APart = zpClient) and HasSplitter then
dec(Result.Right, dSizer);
end;
end;
end;
function TEasyDockHeader.FindPart(AZone: TCustomDockZone; MousePos: TPoint; fButtonDown: boolean): TEasyZonePart;
var
SubRect, r: TRect;
Control: TControl;
Part: TEasyZonePart;
aHandle : HWND;
function MouseInPart(APart: TEasyZonePart): boolean;
begin
//on hit: retain Part and SubRect
SubRect := GetRectOfPart(r, Control.DockOrientation, APart, AZone.HasSizer);
Result := PtInRect(SubRect, MousePos);
if Result then
Part := APart;
end;
begin
(* Called from mouse message handler (only!).
Remember draw state of current zone.
*)
r := AZone.GetBounds;
if (AZone.FChildControl = nil) or not PtInRect(r, MousePos) then
Result := zpNowhere
else begin
Control := AZone.FChildControl;
{
if Control.DockOrientation = doVertical then
r.Bottom := Control.Top
else
r.Right := Control.Left;
if not PtInRect(r, MousePos) then
Part := zpClient //if not in header, must be in control
}
if MouseInPart(zpSizer) or MouseInPart(zpCloseButton)
{$IFDEF restore}
or MouseInPart(zpRestoreButton)
{$ENDIF}
or MouseInPart(zpClient)
then
//all done
else
Part := zpCaption;
end;
aHandle:=AZone.GetHandle;
//check old state changed
if (self.MouseZone <> nil)
and ((MouseZone <> AZone) or (MousePart <> Part) or (MouseDown <> fButtonDown)) then begin
//reset state?
if MousePart in HeaderButtons then
InvalidateRect(aHandle, @PartRect, false); //old button
end;
//check new state
if (MouseDown <> fButtonDown) and (MousePart in HeaderButtons) then
InvalidateRect(aHandle, @SubRect, false); //new button
//set new state
MouseZone := AZone;
MousePart := Part;
MouseDown := fButtonDown;
PartRect := SubRect;
//done
Result := Part;
end;
procedure TEasyDockHeader.Draw(AZone: TCustomDockZone; ACanvas: TCanvas; ACaption: string; const MousePos: TPoint);
(* Problem with colors on other than win32 widgetsets (gtk2...)
*)
const
clBack = clHighlight;
clFont = clHighlightText;
procedure DrawButton(ARect: TRect; IsMouseDown, IsMouseOver: Boolean; ABitmap: TCustomBitmap); inline;
const
// ------------- Pressed, Hot -----------------------
BtnDetail: array[Boolean, Boolean] of TThemedToolBar =
(
(ttbButtonNormal, ttbButtonHot),
(ttbButtonNormal, ttbButtonPressed)
);
var
Details: TThemedElementDetails;
{$IFDEF old}
dx, dy: integer;
{$ELSE}
{$ENDIF}
begin
Details := ThemeServices.GetElementDetails(BtnDetail[IsMouseDown, IsMouseOver]);
ThemeServices.DrawElement(ACanvas.Handle, Details, ARect);
ARect := ThemeServices.ContentRect(ACanvas.Handle, Details, ARect);
{$IFDEF old}
dx := (ARect.Right - ARect.Left - ABitmap.Width) div 2;
dy := (ARect.Bottom - ARect.Top - ABitmap.Height) div 2;
ACanvas.Draw(ARect.Left + dx, ARect.Top + dy, ABitmap);
{$ELSE}
//DebugLn(Format('Button: (%d,%d)-(%d,%d)', [ARect.Top, ARect.Left, ARect.Bottom, ARect.Right]));
ACanvas.Draw(ARect.Left, ARect.Top, ABitmap);
{$ENDIF}
end;
var
BtnRect: TRect;
ARect, DrawRect: TRect;
// LCL dont handle orientation in TFont
OldFont, RotatedFont: HFONT;
OldMode: Integer;
ALogFont: TLogFont;
IsMouseDown: Boolean; //obsolete
AOrientation: TDockOrientation;
AControl: TControl;
begin
(* Some colors inavailable on some widgetsets!
*)
IsMouseDown := self.MouseDown; // (GetKeyState(VK_LBUTTON) and $80) <> 0;
//debug
AControl := AZone.FChildControl;
AOrientation := AControl.DockOrientation;
ARect := AZone.GetBounds;
BtnRect := ARect;
if AZone.FChildControl.DockOrientation = doVertical then begin
ARect.Bottom := ARect.Top + HeaderSize;
BtnRect.Top := BtnRect.Bottom - dSizer;
end else begin
ARect.Right := ARect.Left + HeaderSize;
BtnRect.Left := BtnRect.Right - dSizer;
end;
DrawRect := ARect;
// splitter no more in header! - BtnRect initialized above
if AZone.HasSizer and not IsMouseDown then begin
ACanvas.Brush.Color := clBtnFace;
ACanvas.FillRect(BtnRect);
end;
//erase?
DrawRect := GetRectOfPart(ARect, AOrientation, zpAll, AZone.HasSizer);
ACanvas.Brush.Color := clBack; // clActiveCaption;
ACanvas.FillRect(DrawRect);
//what's this? (from LDockTree)
InflateRect(DrawRect, -1, -1); //outer bevel?
ACanvas.Brush.Color := clBtnShadow;
ACanvas.FrameRect(DrawRect);
//InflateRect(DrawRect, -1, -1); //inner bevel?
// draw caption
ACanvas.Font.Color := clFont; //clCaptionText;
DrawRect := GetRectOfPart(ARect, AOrientation, zpCaption, AZone.HasSizer);
OldMode := SetBkMode(ACanvas.Handle, TRANSPARENT);
if AOrientation = doVertical then begin
// from msdn: DrawText doesnot support font with orientation and escapement <> 0
DrawText(ACanvas.Handle, PChar(ACaption), -1, DrawRect, DT_LEFT or DT_SINGLELINE or DT_VCENTER)
end else begin
OldFont := 0;
if GetObject(ACanvas.Font.Reference.Handle, SizeOf(ALogFont), @ALogFont) <> 0 then
begin
ALogFont.lfEscapement := 900;
RotatedFont := CreateFontIndirect(ALogFont);
if RotatedFont <> 0 then
OldFont := SelectObject(ACanvas.Handle, RotatedFont);
end;
TextOut(ACanvas.Handle, DrawRect.Left, DrawRect.Bottom, PChar(ACaption), Length(ACaption));
if OldFont <> 0 then
DeleteObject(SelectObject(ACanvas.Handle, OldFont));
end;
SetBkMode(ACanvas.Handle, OldMode);
// buttons - which colors to use?
ACanvas.Brush.Color := clBtnFace;
//ACanvas.Pen.Color := clButtonText;
// draw close button
BtnRect := GetRectOfPart(ARect, AOrientation, zpCloseButton, AZone.HasSizer);
ACanvas.FillRect(BtnRect);
DrawButton(BtnRect, IsMouseDown, PtInRect(BtnRect, MousePos), DockBtnImages[dhiClose]);
{$IFDEF restore}
// draw restore button
BtnRect := GetRectOfPart(ARect, AOrientation, zpRestoreButton, AZone.hasSizer);
ACanvas.FillRect(BtnRect);
DrawButton(BtnRect, IsMouseDown, PtInRect(BtnRect, MousePos), DockBtnImages[dhiRestore]);
{$ENDIF}
end;
{ TCustomDockZone }
function TCustomDockZone.GetBounds: TRect;
begin
Result := FChildControl.BaseBounds; //avoid (0,0,0,0)
end;
function TCustomDockZone.GetHeaderSize: integer;
begin
Result := dHeader; //???
end;
function TCustomDockZone.GetRectOfPart(APart: TEasyZonePart): TRect;
begin
(* This method could hold the entire implementation.
*)
if FChildControl = nil then
Result := Rect(0,0,0,0)
else
Result := TEasyDockHeader.GetRectOfPart(GetBounds, FChildControl.DockOrientation, APart, HasSizer);
end;
function TCustomDockZone.HasSizer: boolean;
begin
Result := True; //always show - simplest solution?
end;
initialization
{$I easy_dock_images.lrs}
CreateDockHeaderImages;
finalization
DestroyDockHeaderImages;
end.

457
examples/dockmanager/easytree/easydocksite.pas
View File

@ -41,19 +41,48 @@ uses
LCLType, //HDC
LMessages, //TLMessage
Classes, //TStream
Graphics, //TCanvas
Forms,
ExtCtrls, //splitter
Controls,
ComCtrls, //TPageControl
EasyDockHelpers;
ComCtrls; //TPageControl
type
TEasyTree = class; //forward declaration
TEasyZone = class; //forward declaration
TEasySplitter = TCustomSplitter;
{ TEasyZone }
TEasyZonePart =
(
zpNowhere, // not in any zone
zpClient, // on client control
zpAll, // total header rect
zpCaption, // header caption
zpSizer, // splitter/sizer
{$IFDEF restore}
zpRestoreButton, // header restore button
{$ENDIF}
zpCloseButton // header close button
);
TEasyZone = class(TCustomDockZone)
TEasyDockHeader = class
public
HeaderSize: integer;
//state last drawn
MouseZone: TEasyZone;
MouseDown: boolean;
MousePart: TEasyZonePart;
PartRect: TRect;
public
constructor Create;
class function GetRectOfPart(AHeaderRect: TRect; AOrientation: TDockOrientation; APart: TEasyZonePart; HasSplitter: boolean): TRect; virtual;
function FindPart(AZone: TEasyZone; MousePos: TPoint; fButtonDown: boolean): TEasyZonePart;
procedure Draw(AZone: TEasyZone; ACanvas: TCanvas; ACaption: string; const MousePos: TPoint);
end;
TEasyZone = class
private
FChildControl: TControl;
FTree: TEasyTree;
FFirstChild,
FNextSibling, FPrevSibling, FParent: TEasyZone;
@ -63,10 +92,7 @@ type
function GetLeft: Integer;
function GetTop: Integer;
function GetTopOrLeft(fTop: boolean): Integer;
private //very basic linking
(* Beware: Lazarus tends to insert a private member FChildControl,
which hides the inherited member of the same name!
*)
private //very basic liniking
procedure InsertAfter(LinkAfter, NewZone: TEasyZone);
//do not handle orientation!
procedure SetParent(zone: TEasyZone);
@ -75,8 +101,8 @@ type
BR: TPoint;
procedure SetBounds(TLBR: TRect);
function GetHandle: HWND; override;
function GetHeaderSize: integer; override;
function GetHandle: HWND;
function GetHeaderSize: integer;
function GetVisible: boolean;
function GetVisibleControl: TControl;
function GetPartRect(APart: TEasyZonePart): TRect;
@ -85,8 +111,8 @@ type
destructor Destroy; override;
procedure Clear;
function DockSite: TWinControl;
function HasSizer: boolean; override;
function GetBounds: TRect; override;
function HasSizer: boolean;
function GetBounds: TRect;
procedure AddSibling(NewZone: TEasyZone; where: TAlign);
procedure ReplaceChild(OldChild, NewChild: TEasyZone);
@ -121,6 +147,7 @@ type
procedure BeginUpdate; override;
procedure EndUpdate; override;
//extended interface
//procedure ControlVisibilityChanged(Control: TControl; Visible: Boolean); override;
function ZoneFromPoint(SitePos: TPoint): TEasyZone;
procedure GetControlBounds(Control: TControl; out CtlBounds: TRect); override;
procedure InsertControl(Control: TControl; InsertAt: TAlign;
@ -129,7 +156,7 @@ type
var DockRect: TRect); override;
procedure RemoveControl(Control: TControl); override;
procedure ResetBounds(Force: Boolean); override; //site resized
procedure SetReplacingControl(Control: TControl); override; //unused, Delphi compatible
procedure SetReplacingControl(Control: TControl); override; //unused
procedure LoadFromStream(Stream: TStream); override;
procedure SaveToStream(Stream: TStream); override;
protected //added
@ -142,7 +169,7 @@ type
private
FHeader: TEasyDockHeader;
FSplitter: TEasySplitter;
FSizeZone: TEasyZone; //zone to be resized, along with NextSibling
FSizeZone: TEasyZone; //zone to be resized, also PrevSibling
procedure SplitterMoved(Sender: TObject); //hide and reposition zone
public
procedure MouseMessage(var Message: TLMessage); override;
@ -178,14 +205,17 @@ var //debug only
implementation
uses
SysUtils, Types, Graphics,
SysUtils, Types,
math,
Themes, LResources,
LCLproc; //debugging
const
ParentChildOrientation: array[TDockOrientation] of TDockOrientation = (
doNoOrient, doVertical, doHorizontal, doPages
);
{$IFDEF restore}
HeaderButtons = [zpCloseButton, zpRestoreButton];
{$ELSE}
HeaderButtons = [zpCloseButton];
{$ENDIF}
//from CustomFormEditor.pp
function {TCustomFormEditor.}CreateUniqueComponentName(const AClassName: string;
@ -236,10 +266,9 @@ begin
//FreeAndNil(DockSite.DockManager); - seems to be fixed
DockSite.DockManager := self;
//init node class - impossible due to visibility restrictions!
inherited Create; //(DockSite);
//init top zone
FSiteRect := DockSite.ClientRect; //handle resize of the dock site
FSiteRect := DockSite.ClientRect;
FTopZone := TEasyZone.Create(self);
FTopZone.SetBounds(FSiteRect);
//init helpers
@ -277,7 +306,6 @@ begin
if (FUpdateCount = 0) and (FTopZone.FirstChild <> nil) then begin
DebugLn('EndUpdate---');
UpdateTree;
//BuildDockLayout(FTopZone);
end;
end;
@ -285,7 +313,7 @@ function TEasyTree.ZoneFromPoint(SitePos: TPoint): TEasyZone;
var
zone: TEasyZone;
begin
(* Return zone a site client coordinates.
(* Return zone in site client coordinates.
*)
zone := FTopZone;
while zone <> nil do begin
@ -308,7 +336,6 @@ end;
procedure TEasyTree.AdjustDockRect(Control: TControl; var ARect: TRect);
begin
//get the client area within the given zone rectangle
//raw extimate, lacking exact (not yet existing) zone information
if Control.DockOrientation = doVertical then
inc(ARect.Top, DockHeaderSize)
else
@ -341,6 +368,7 @@ begin
if zone = nil then
CtlBounds := Rect(0,0,0,0)
else begin
{ TODO -cdocking : zpClient }
CtlBounds := zone.GetBounds;
end;
end;
@ -360,6 +388,7 @@ In all other cases all zones have an orientation:
Cases 2 and 3 can be merged, with an additional or redundant setting of the orientation.
*)
begin
if Control = FReplacingControl then begin
(* hack for morphing DropCtl into notebook,
@ -421,16 +450,16 @@ begin
exit;
end;
NewZone := TEasyZone.Create(self);
NewZone.ChildControl := Control as TControl;
Control.Align := alNone; //hack: prevent reposition by host
Control.Align := alNone;
//special case: in root zone (empty dock site)
if FTopZone.FirstChild = nil then begin
//special case: in root zone (empty dock site)
FTopZone.InsertAfter(nil, NewZone);
NewZone.SetBounds(FDockSite.ClientRect);
end else begin //normal dock, along with existing zones
end else begin
//more checks
OldZone := FindControlZone(FTopZone, Control);
//check after placing the control
@ -442,7 +471,7 @@ begin
else //unhandled or unspecific
if DropCtl.DockOrientation = doNoOrient then
DropCtl.DockOrientation := doHorizontal; //assume
Control.DockOrientation := ParentChildOrientation[DropCtl.DockOrientation];
Control.DockOrientation := DropCtl.DockOrientation;
//fix alignment
if Control.DockOrientation = doVertical then
InsertAt := alBottom
@ -454,22 +483,23 @@ begin
InsertAt is one of alLeft/Right/Top/Bottom
*)
//check orientation - control orientation cannot be doNoOrient!
//check orientation - control orientation cannot be doNone!
OldParent := DropZone.Parent;
(* One special case remains: top zone without orientation
*)
if (OldParent.Orientation = doNoOrient) then begin
assert(OldParent = FTopZone, '???');
FTopZone.Orientation := ParentChildOrientation[Control.DockOrientation]; //easy
FTopZone.Orientation := Control.DockOrientation; //easy
end;
//iso or orthogonal insert?
if (OldParent.Orientation <> ParentChildOrientation[Control.DockOrientation]) then begin
//need intermediate zone, due to different alignment
if (OldParent.Orientation <> Control.DockOrientation) then begin
//need intermediate zone
NewParent := TEasyZone.Create(self);
NewParent.Orientation := Control.DockOrientation;
NewParent.BR := r.BottomRight;
OldParent.ReplaceChild(DropZone, NewParent); //unlink DropZone
//now: orthogonal orientation
//orthogonal orientation
//DropZone.SetBounds(r);
NewParent.InsertAfter(nil, DropZone);
end;
//set control orientation
@ -483,6 +513,138 @@ begin
FDockSite.Invalidate;
end;
procedure TEasyTree.PositionDockRect(ADockObject: TDragDockObject);
var
i: integer;
zone: TEasyZone;
function DetectAlign(ZoneSize, MousePos: TPoint): TAlign;
var
w, h, zphi: integer;
dx, dy: integer;
phi: double;
izone: integer;
//zone: eZone;
dir: TAlign;
const
k = 5; //matrix dimension
//mapping octants into aligns, assuming k=5
cDir: array[-4..4] of TAlign = (
alLeft, alLeft, alTop, alTop, alRight, alBottom, alBottom, alLeft, alLeft
);
begin
//center of dock zone
w := ZoneSize.x div 2;
h := ZoneSize.y div 2;
//mouse position within k*k rectangles (squares)
dx := trunc((MousePos.x - w) / w * k);
dy := trunc((MousePos.y - h) / h * k);
izone := max(abs(dx), abs(dy)); //0..k
//map into 0=innermost (custom), 1=inner, 2=outer
if izone = 0 then begin
//zone := zInnermost;
dir := alCustom; //pages
end else begin
{
if izone >= k-1 then
zone := zOuter
else //if izone > 0 then
zone := zInner;
}
phi := arctan2(dy, dx);
zphi := trunc(radtodeg(phi)) div 45;
dir := cDir[zphi];
end;
Result := dir;
end;
var
ZoneExtent: TPoint;
ADockRect: TRect;
begin
(* New DockManager interface, called instead of the old version.
Determine exact target (zone) and DropAlign.
Signal results:
Prevent docking by setting DropOnControl=Control (prevent changes when dropped).
DragTarget=nil means: become floating.
Unfortunately there exists no way to signal invalid docking attempts :-(
*)
//debug only
DockObj := ADockObject;
//determine the zone containing the DragTargetPos
with ADockObject do begin
//mouse position within dock site
DragTargetPos := DragTarget.ScreenToClient(DragPos);
//find zone
zone := ZoneFromPoint(DragTargetPos);
if (zone = nil) or (Control = zone.ChildControl) then begin
DropAlign := alNone; //prevent drop (below)
end else begin
ADockRect := zone.GetBounds; //include header
DropOnControl := zone.ChildControl;
if DropOnControl = nil then begin
DropAlign := alClient //first element in entire site
end else //determine the alignment within the zone.
DropAlign := DetectAlign(zone.BR, DragTargetPos);
//to screen coords
ADockRect.TopLeft := FDockSite.ClientToScreen(ADockRect.TopLeft);
ADockRect.BottomRight := FDockSite.ClientToScreen(ADockRect.BottomRight);
end;
//position DockRect
if DropAlign = alNone then begin
//force DockRect update by DockTrackNoTarget
DropOnControl := Control; //prevent drop - signal drop onto self
{$IFDEF NoDrop}
NoDrop := True;
{$ELSE}
DragTarget := nil;
//Control.DockTrackNoTarget
//DragTarget := FDockSite; //prevent floating - doesn't work :-(
//DockRect := Rect(MaxInt, MaxInt, 0, 0); //LTRB - very strange effect!
//DockRect := Rect(MaxInt, 0, MaxInt, 0); //LTRB
{$ENDIF}
end else begin
PositionDockRect(Control, DropOnControl, DropAlign, ADockRect);
DockRect := ADockRect;
end;
end;
end;
procedure TEasyTree.PositionDockRect(Client, DropCtl: TControl;
DropAlign: TAlign; var DockRect: TRect);
var
wh: integer;
begin
(* DockRect is initialized to the screen rect of the dock site by TControl,
or to the zone rect by TEasyTree.
*)
//debug!
DropOn := DropCtl;
if (DropCtl = nil) then
exit; //empty dock site
case DropAlign of
//alClient: as is
alTop: DockRect.Bottom := (DockRect.Top + DockRect.Bottom) div 2;
alBottom: DockRect.Top := (DockRect.Top + DockRect.Bottom) div 2;
alLeft: DockRect.Right := (DockRect.Left + DockRect.Right) div 2;
alRight: DockRect.Left := (DockRect.Left + DockRect.Right) div 2;
alCustom: //pages
begin
wh := (DockRect.Right - DockRect.Left) div 3;
inc(DockRect.Left, wh);
dec(DockRect.Right, wh);
wh := (DockRect.Bottom - DockRect.Top) div 3;
inc(DockRect.Top, wh);
dec(DockRect.Bottom, wh);
end;
end;
end;
procedure TEasyTree.LoadFromStream(Stream: TStream);
begin
//todo
@ -519,7 +681,7 @@ var
//also set splitter range! (todo)
FSizeZone := z; //now: the zone with the header (second sibling!)
FSplitter.BoundsRect := FHeader.PartRect;
if z.Parent.Orientation = doHorizontal then begin
if z.Parent.Orientation = doVertical then begin
FSplitter.ResizeAnchor := akTop
end else begin
FSplitter.ResizeAnchor := akLeft;
@ -571,21 +733,20 @@ end;
procedure TEasyTree.SplitterMoved(Sender: TObject);
var
ptNew, ptOuter: TPoint;
ptNew: TPoint;
begin
(* The unbound splitter has been moved.
Reflect new sizes in FSizeZone and next sibling.
Reflect new sizes in FSizeZone and prev(!) sibling.
ptOuter is the new parent extent, BR of the last sibling.
*)
FSplitter.Hide;
ptNew := FSizeZone.BR;
if FSizeZone.Parent.Orientation = doHorizontal then
ptNew.y := FSplitter.Top + FSplitter.Height //above (and including) splitter
ptNew := FSizeZone.PrevSibling.BR;
if FSizeZone.Parent.Orientation = doVertical then
ptNew.y := FSplitter.Top //above splitter
else
ptNew.x := FSplitter.Left + FSplitter.Width; //left of splitter
ptOuter := FSizeZone.Parent.BR; //not affected
FSizeZone.ScaleTo(FSizeZone.BR, ptNew, ptNew); // ptOuter);
FSizeZone.NextSibling.SetBounds(FSizeZone.NextSibling.GetBounds); //BR unchanged, only update the control
ptNew.x := FSplitter.Left; //left of splitter
FSizeZone.PrevSibling.ScaleTo(FSizeZone.PrevSibling.BR, ptNew, ptNew);
FSizeZone.SetBounds(FSizeZone.GetBounds); //BR unchanged, only update the control
{ TODO -cdocking : Invalidate seems to miss a repaint of the docked controls, sometimes? }
FDockSite.Invalidate;
end;
@ -624,147 +785,6 @@ begin
PaintZone(FTopZone);
end;
procedure TEasyTree.PositionDockRect(ADockObject: TDragDockObject);
var
i: integer;
zone: TEasyZone;
function DetectAlign(ZoneSize, MousePos: TPoint): TAlign;
var
w, h, zphi: integer;
dx, dy: integer;
phi: double;
izone: integer;
//zone: eZone;
dir: TAlign;
const
k = 5; //matrix dimension
//mapping octants into aligns, assuming k=5
cDir: array[-4..4] of TAlign = (
alLeft, alLeft, alTop, alTop, alRight, alBottom, alBottom, alLeft, alLeft
);
begin
//center of dock zone
w := ZoneSize.x div 2;
h := ZoneSize.y div 2;
//mouse position within k*k rectangles (squares)
dx := trunc((MousePos.x - w) / w * k);
dy := trunc((MousePos.y - h) / h * k);
izone := max(abs(dx), abs(dy)); //0..k
//map into 0=innermost (custom), 1=inner, 2=outer
if izone = 0 then begin
//zone := zInnermost;
dir := alCustom; //alClient?
end else begin
{ future feature: inner and outer location.
outmost location intended to span all siblings.
if izone >= k-1 then
zone := zOuter
else //if izone > 0 then
zone := zInner;
}
phi := arctan2(dy, dx);
zphi := trunc(radtodeg(phi)) div 45;
dir := cDir[zphi];
end;
Result := dir;
end;
var
ZoneExtent: TPoint;
ADockRect: TRect;
begin
(* New DockManager interface, called instead of the old version.
Determine exact target (zone) and DropAlign.
Signal results:
Prevent docking by setting DropOnControl=Control (prevent changes when dropped).
DragTarget=nil means: become floating.
Unfortunately there exists no way to signal invalid docking attempts :-(
*)
//debug only
DockObj := ADockObject;
//determine the zone containing the DragTargetPos
with ADockObject do begin
//mouse position within dock site
DragTargetPos := DragTarget.ScreenToClient(DragPos);
//find zone
zone := ZoneFromPoint(DragTargetPos);
if (zone = nil) or (Control = zone.ChildControl) then begin
DropAlign := alNone; //prevent drop (below)
end else begin
ADockRect := zone.GetBounds; //include header
DropOnControl := zone.ChildControl;
if DropOnControl = nil then begin
DropAlign := alClient; //first element in entire site
end else //determine the alignment within the zone.
DropAlign := DetectAlign(zone.BR, DragTargetPos);
//to screen coords
ADockRect.TopLeft := FDockSite.ClientToScreen(ADockRect.TopLeft);
ADockRect.BottomRight := FDockSite.ClientToScreen(ADockRect.BottomRight);
end;
//position DockRect
if DropAlign = alNone then begin
//force DockRect update by DockTrackNoTarget
DropOnControl := Control; //prevent drop - signal drop onto self
{$IFDEF NoDrop}
NoDrop := True;
{$ELSE}
DragTarget := nil;
//Control.DockTrackNoTarget
//DragTarget := FDockSite; //prevent floating - doesn't work :-(
//DockRect := Rect(MaxInt, MaxInt, 0, 0); //LTRB - very strange effect!
//DockRect := Rect(MaxInt, 0, MaxInt, 0); //LTRB
{$ENDIF}
end else begin
PositionDockRect(Control, DropOnControl, DropAlign, ADockRect);
DockRect := ADockRect;
end;
end;
end;
procedure TEasyTree.PositionDockRect(Client, DropCtl: TControl;
DropAlign: TAlign; var DockRect: TRect);
var
wh: integer;
begin
(* DockRect is initialized to the screen rect of the dock site by TControl,
or to the zone rect by TEasyTree!
We assume call by TEasyTree...
*)
//debug!
DropOn := DropCtl;
if (DropCtl = nil) then begin
//DebugLn('no DropCtl');
exit; //empty dock site
end;
{
with DockRect do
DebugLn('drop onto %s[%d,%d - %d,%d] %s', [
DropCtl.Name, Top, Left, Bottom, Right, AlignNames[DropAlign]
]);
}
case DropAlign of
//alClient: as is
alTop: DockRect.Bottom := (DockRect.Top + DockRect.Bottom) div 2;
alBottom: DockRect.Top := (DockRect.Top + DockRect.Bottom) div 2;
alLeft: DockRect.Right := (DockRect.Left + DockRect.Right) div 2;
alRight: DockRect.Left := (DockRect.Left + DockRect.Right) div 2;
alCustom:
begin
wh := (DockRect.Right - DockRect.Left) div 3;
inc(DockRect.Left, wh);
dec(DockRect.Right, wh);
wh := (DockRect.Bottom - DockRect.Top) div 3;
inc(DockRect.Top, wh);
dec(DockRect.Bottom, wh);
end;
end;
end;
procedure TEasyTree.RemoveControl(Control: TControl);
var
zone: TEasyZone;
@ -786,14 +806,15 @@ begin
exit; //not the right time to do anything
if FTopZone.FirstChild = nil then
exit; //zone is empty, nothing to do
//how to determine old bounds? We use saved size in FSiteRect.
//how to determine old bounds?
rNew := FDockSite.ClientRect;
if not Force and not CompareMem(@rNew, @FSiteRect, sizeof(rNew)) then
if not CompareMem(@rNew, @FSiteRect, sizeof(rNew)) then
Force := True; //something has changed
if not Force then
exit;
FTopZone.ScaleTo(FSiteRect.BottomRight, rNew.BottomRight, rNew.BottomRight);
FSiteRect := rNew;
FSplitter.Hide;
FDockSite.Invalidate; //force repaint of headers
end;
@ -819,14 +840,14 @@ const
else
s := '''''';
r := zone.GetBounds;
s := Format('%s%s (%d,%d)-(%d,%d)%s', [ind, OrientString[zone.orientation], //zone.Limit,
s := Format('%s%s (%d,%d)-(%d,%d)%s', [ind, OrientString[zone.orientation],
r.Top, r.Left, r.Bottom, r.Right, eol]);
Stream.Write(s[1], length(s));
//control
ctl := zone.ChildControl;
if ctl <> nil then begin
r := ctl.BoundsRect;
s := Format('%s%s %s.%s (%d,%d)-(%d,%d)%s', [ind, OrientString[zone.orientation],
s := Format('%s%s %s.%s (%d,%d)-(%d,%d)%s', [ind, OrientString[ctl.DockOrientation],
ctl.ClassName, ctl.Name,
r.Top, r.Left, r.Bottom, r.Right, eol]);
Stream.Write(s[1], length(s));
@ -846,10 +867,6 @@ const
end;
begin
(* This is a debug version of SaveToStream.
It only produces a readable representation of the internal structure,
not suited for restoring the layout with LoadFromStream.
*)
//for now: dump tree
//splitter
if FSplitter.Visible then begin
@ -868,6 +885,7 @@ end;
procedure TEasyTree.UpdateTree;
begin
//nothing to do?
//FDockSite.Invalidate;
end;
@ -934,7 +952,7 @@ begin
//more than 1 child - check next level
end else if ch.FirstChild = nil then begin
//contains control, move up
ch.ChildControl.DockOrientation := ParentChildOrientation[zone.Parent.Orientation];
ch.ChildControl.DockOrientation := zone.Parent.Orientation;
p.ReplaceChild(zone, ch); //move control up
zone.Free;
affected := p;
@ -947,13 +965,17 @@ begin
zone := p;
end;
//update parent(?) zone, to close the gap
//Zone := p.FirstChild;
if affected <> nil then begin
Zone := affected.FirstChild;
while Zone <> nil do begin
if Zone.NextSibling = nil then
//Zone.BR := p.BR; //resize last zone
Zone.BR := affected.BR; //resize last zone
if Zone.ChildControl <> nil then begin
Zone.ChildControl.BoundsRect := Zone.GetPartRect(zpClient);
r := Zone.GetBounds;
AdjustDockRect(Zone.ChildControl, r);
Zone.ChildControl.BoundsRect := r;
end;
zone := Zone.NextSibling;
end;
@ -1030,9 +1052,7 @@ end;
function TEasyZone.HasSizer: boolean;
begin
(* New sizer at bottom/right of zone (was: part of header)
*)
Result := NextSibling <> nil;
Result := PrevSibling <> nil;
end;
//-------------- basic linking ----------------
@ -1070,13 +1090,14 @@ begin
LinkAfter.NextSibling.FPrevSibling := NewZone;
LinkAfter.FNextSibling := NewZone;
end;
//NewZone.Orientation := LinkAfter.Orientation;
end;
procedure TEasyZone.AddSibling(NewZone: TEasyZone; where: TAlign);
var
LinkAfter: TEasyZone;
r, r2: TRect;
NewOrientation: TDockOrientation; //of the child control
NewOrientation: TDockOrientation;
begin
//orientation is NOT checked!
r := GetBounds; //valid old values
@ -1119,7 +1140,7 @@ begin
end;
//parent orientation? (if in rootzone)
//if parent.Orientation = doNoOrient then
Parent.Orientation := ParentChildOrientation[NewOrientation];
Parent.Orientation := NewOrientation;
if ChildControl <> nil then
ChildControl.DockOrientation := NewOrientation;
if NewZone.ChildControl <> nil then
@ -1167,7 +1188,7 @@ begin
//exact boundary in parent orientation
if (Parent = nil) or (Parent.Orientation = doNoOrient) then
br := ptOuter
else if Parent.Orientation <> doVertical then begin
else if Parent.Orientation = doVertical then begin
br.X := ptOuter.X;
if NextSibling = nil then
br.Y := ptOuter.Y
@ -1182,9 +1203,9 @@ begin
end;
if ChildControl <> nil then begin
//r := GetBounds;
//FTree.AdjustDockRect(ChildControl, r);
ChildControl.BoundsRect := GetPartRect(zpClient);
r := GetBounds;
FTree.AdjustDockRect(ChildControl, r);
ChildControl.BoundsRect := r;
end else begin
ch := FirstChild;
while ch <> nil do begin
@ -1215,10 +1236,10 @@ function TEasyZone.GetTopOrLeft(fTop: boolean): Integer;
var
zone, prev: TEasyZone;
begin
// In a parent zone of vertical orientation the zone.PrevSibling.Bottom is zone.Left
// In a parent zone of vertical orientation the zone.PrevSibling.Bottom is zone.Top
zone := self;
while zone.Parent <> nil do begin
if (fTop = (zone.Parent.Orientation = doHorizontal)) then begin
if (fTop = (zone.Parent.Orientation = doVertical)) then begin
prev := zone.PrevSibling;
while prev <> nil do begin
if prev.Visible then begin
@ -1263,30 +1284,20 @@ end;
procedure TEasyZone.SetBounds(TLBR: TRect);
var
z: TEasyZone;
r, rc: TRect;
begin
(* Zone cannot be the root zone. If so, ignore?
Recurse into child zones.
*)
BR := TLBR.BottomRight;
if ChildControl <> nil then begin //is control zone
ChildControl.Align := alNone;
r := GetPartRect(zpClient);
ChildControl.BoundsRect := r;
rc := ChildControl.BoundsRect;
//check control reacted properly
if not CompareMem(@r, @rc, sizeof(r)) then begin
with r do begin
DebugLn('BoundsRect as (%d,%d)-(%d,%d)', [Top, Left, Bottom, Right]);
end;
with rc do
DebugLn('BoundsRect is (%d,%d)-(%d,%d)', [Top, Left, Bottom, Right]);
end;
FTree.AdjustDockRect(ChildControl, TLBR);
ChildControl.BoundsRect := TLBR;
end else if FirstChild <> nil then begin
//if Orientation = doVertical then TLBR.;
z := FirstChild;
while z <> nil do begin
//resize - for splitter move only!
if Orientation = doHorizontal then //left/right changed
if Orientation = doVertical then //left/right changed
z.BR.x := TLBR.Right
else
z.BR.y := TLBR.Bottom;
@ -1342,5 +1353,13 @@ begin
end;
end;
//implement various headers
{$I zoneheader.inc}
initialization
{$I easy_dock_images.lrs}
CreateDockHeaderImages;
finalization
DestroyDockHeaderImages;
end.

2
examples/dockmanager/easytree/fmain.lrs
View File

@ -1,3 +1,5 @@
{ Das ist eine automatisch erzeugte Lazarus-Ressourcendatei }
LazarusResources.Add('TEasyDockMain','FORMDATA',[
'TPF0'#13'TEasyDockMain'#12'EasyDockMain'#4'Left'#3#168#2#6'Height'#3#29#1#3
+'Top'#2'}'#5'Width'#3#205#1#13'ActiveControl'#7#6'buDump'#7'Caption'#6#12'Ea'

349
examples/dockmanager/easytree/zoneheader.inc Normal file
View File

@ -0,0 +1,349 @@
type
TDockHeaderImageKind =
(
dhiRestore,
dhiClose
);
TDockHeaderImages = array[TDockHeaderImageKind] of TCustomBitmap;
const
DockHeaderImageNames: array[TDockHeaderImageKind] of String =
(
{ dhiRestore } 'easy_dock_restore',
{ dhiClose } 'easy_dock_close'
);
var
DockBtnImages: TDockHeaderImages;
procedure CreateDockHeaderImages;
var
ImageKind: TDockHeaderImageKind;
begin
for ImageKind := Low(TDockHeaderImageKind) to High(TDockHeaderImageKind) do
DockBtnImages[ImageKind] := CreateBitmapFromLazarusResource(DockHeaderImageNames[ImageKind]);
end;
procedure DestroyDockHeaderImages;
var
ImageKind: TDockHeaderImageKind;
begin
for ImageKind := Low(TDockHeaderImageKind) to High(TDockHeaderImageKind) do
FreeAndNil(DockBtnImages[ImageKind]);
end;
{ TEasyDockHeader }
const
dSizer = 4;
dBorder = 2; //frame and inner bevel
dDist = 1; //button distance
{$IFDEF newsplitter}
dHeader = 22 - dSizer; //splitter outside header!
{$ELSE}
dHeader = 22;
{$ENDIF}
constructor TEasyDockHeader.Create;
{
procedure dump;
var
r, r2: TRect;
begin
r := Rect(0, 0, 200, HeaderSize); //LTBR
r2 := GetRectOfPart(r, doVertical, zpCaption);
DebugLn('%s (%d,%d)-(%d,%d)', ['caption', r2.Top, r2.Left, r2.Bottom, r2.Right]);
r2 := GetRectOfPart(r, doVertical, zpCloseButton);
DebugLn('%s (%d,%d)-(%d,%d)', ['closer ', r2.Top, r2.Left, r2.Bottom, r2.Right]);
r2 := GetRectOfPart(r, doVertical, zpSizer);
DebugLn('%s (%d,%d)-(%d,%d)', ['sizer ', r2.Top, r2.Left, r2.Bottom, r2.Right]);
end;
}
begin
HeaderSize := dHeader; //some meaningful value?
//debug
//dump;
end;
class function TEasyDockHeader.GetRectOfPart(AHeaderRect: TRect; AOrientation: TDockOrientation;
APart: TEasyZonePart; HasSplitter: boolean): TRect;
var
d, dRight, dWidth: Integer;
begin
if (APart = zpNowhere) or (APart = zpClient)
or ((APart = zpSizer) and not HasSplitter) then begin
Result := Rect(0,0,0,0);
exit;
end;
Result := AHeaderRect;
//if APart = zpAll then Exit; //include sizer?
if APart = zpSizer then begin
//at top/left - visible only if HasSplitter
if AOrientation = doVertical then
Result.Bottom := Result.Top + dSizer
else
Result.Right := Result.Left + dSizer;
exit;
end;
//exclude sizer
if not HasSplitter then begin
if AOrientation = doVertical then
inc(Result.Top, dSizer)
else
inc(Result.Left, dSizer);
end;
if APart = zpAll then
Exit; //exclude sizer
//exclude border, assume 1 pixel border, 1 pixel inner distance
InflateRect(Result, -dBorder, -dBorder); //border(2), remaining = rectangular button width/height
//get remaining size for buttons
if AOrientation = doVertical then
d := Result.Bottom - Result.Top
else
d := Result.Right - Result.Left;
dWidth := 0;
case APart of
//zpAll: - see above
zpCloseButton: dRight := dDist;
{$IFDEF restore}
zpRestoreButton: dRight := d + 2*dDist;
zpCaption: dWidth := 2*(d + dDist); //2 * (button + dist)
{$ELSE}
zpCaption: dWidth := (d + dDist); //1 * (button + dist)
{$ENDIF}
//zpSizer: - see above
//zpClient, //here: invalid argument!
//zpNowhere: Result := Rect(0,0,0,0);
end;
if AOrientation = doVertical then begin
if dWidth > 0 then begin //caption
dec(Result.Right, dBorder+dWidth);
end else begin //buttons
dec(Result.Right, dBorder+dRight);
Result.Left := Result.Right - d;
end;
end else begin
if dWidth > 0 then begin //caption
inc(Result.Top, dBorder+dWidth);
end else begin //buttons
inc(Result.Top, dBorder+dRight);
Result.Bottom := Result.Top + d;
end;
end;
end;
function TEasyDockHeader.FindPart(AZone: TEasyZone; MousePos: TPoint; fButtonDown: boolean): TEasyZonePart;
var
SubRect, r: TRect;
Control: TControl;
Part: TEasyZonePart;
aHandle : HWND;
function MouseInPart(APart: TEasyZonePart): boolean;
begin
//on hit: retain Part and SubRect
SubRect := GetRectOfPart(r, Control.DockOrientation, APart, AZone.HasSizer);
Result := PtInRect(SubRect, MousePos);
if Result then
Part := APart;
end;
begin
(* Called from mouse message handler (only!).
Remember draw state of current zone.
*)
r := AZone.GetBounds;
if (AZone.FChildControl = nil) or not PtInRect(r, MousePos) then
Result := zpNowhere
else begin
Control := AZone.FChildControl;
if Control.DockOrientation = doVertical then
r.Bottom := Control.Top
else
r.Right := Control.Left;
if not PtInRect(r, MousePos) then
Part := zpClient //if not in header, must be in control
else if MouseInPart(zpSizer) or MouseInPart(zpCloseButton)
{$IFDEF restore}
or MouseInPart(zpRestoreButton)
{$ENDIF}
then
//all done
else
Part := zpCaption;
end;
aHandle:=AZone.GetHandle;
//check old state changed
if (self.MouseZone <> nil)
and ((MouseZone <> AZone) or (MousePart <> Part) or (MouseDown <> fButtonDown)) then begin
//reset state?
if MousePart in HeaderButtons then
InvalidateRect(aHandle, @PartRect, false); //old button
end;
//check new state
if (MouseDown <> fButtonDown) and (MousePart in HeaderButtons) then
InvalidateRect(aHandle, @SubRect, false); //new button
//set new state
MouseZone := AZone;
MousePart := Part;
MouseDown := fButtonDown;
PartRect := SubRect;
//done
Result := Part;
end;
procedure TEasyDockHeader.Draw(AZone: TEasyZone; ACanvas: TCanvas; ACaption: string; const MousePos: TPoint);
(* Problem with colors on other than win32 widgetsets (gtk2...)
*)
{$DEFINE LDock} //mimic LDockTree?
const
clBack = clHighlight;
clFont = clHighlightText;
procedure DrawButton(ARect: TRect; IsMouseDown, IsMouseOver: Boolean; ABitmap: TCustomBitmap); inline;
const
// ------------- Pressed, Hot -----------------------
BtnDetail: array[Boolean, Boolean] of TThemedToolBar =
(
(ttbButtonNormal, ttbButtonHot),
(ttbButtonNormal, ttbButtonPressed)
);
var
Details: TThemedElementDetails;
dx, dy: integer;
begin
Details := ThemeServices.GetElementDetails(BtnDetail[IsMouseDown, IsMouseOver]);
ThemeServices.DrawElement(ACanvas.Handle, Details, ARect);
ARect := ThemeServices.ContentRect(ACanvas.Handle, Details, ARect);
//zoom button into rect?
{$IFDEF LDock}
dx := (ARect.Right - ARect.Left - ABitmap.Width) div 2;
dy := (ARect.Bottom - ARect.Top - ABitmap.Height) div 2;
ACanvas.Draw(ARect.Left + dx, ARect.Top + dy, ABitmap);
{$ELSE}
ACanvas.Draw(ARect.Left, ARect.Top, ABitmap);
{$ENDIF}
end;
var
BtnRect: TRect;
ARect, DrawRect: TRect;
// LCL doesn't handle orientation in TFont
OldFont, RotatedFont: HFONT;
OldMode: Integer;
ALogFont: TLogFont;
IsMouseDown: Boolean; //obsolete
AOrientation: TDockOrientation;
AControl: TControl;
begin
(* Some colors inavailable on some widgetsets!
(NewSplitter at opposite side of header! - not in this version)
*)
//IsMouseDown := self.MouseDown; // not always correct?
IsMouseDown := (GetKeyState(VK_LBUTTON) and $80) <> 0;
//debug
AControl := AZone.FChildControl;
AOrientation := AControl.DockOrientation;
ARect := AZone.GetBounds;
BtnRect := ARect;
if AZone.FChildControl.DockOrientation = doVertical then begin
ARect.Bottom := ARect.Top + HeaderSize; //entire header area
BtnRect.Top := BtnRect.Bottom - dSizer; //splitter
end else begin
ARect.Right := ARect.Left + HeaderSize;
BtnRect.Left := BtnRect.Right - dSizer;
end;
DrawRect := ARect;
ACanvas.Brush.Color := clBtnFace;
if AZone.HasSizer then begin
{$IFDEF newsplitter}
// splitter no more in header! - BtnRect initialized above
ACanvas.FillRect(BtnRect);
{$ELSE}
//draw splitter?
BtnRect := GetRectOfPart(ARect, AOrientation, zpSizer, AZone.HasSizer);
{$IFDEF LDock}
{$ELSE}
ACanvas.Brush.Color := clBtnFace;
{$ENDIF}
ACanvas.FillRect(BtnRect);
{$ENDIF}
end;
//erase?
DrawRect := GetRectOfPart(ARect, AOrientation, zpAll, AZone.HasSizer);
{$IFDEF LDock}
{$ELSE}
ACanvas.Brush.Color := clBack; // clActiveCaption;
{$ENDIF}
ACanvas.FillRect(DrawRect);
//what's this?
InflateRect(DrawRect, -1, -1); //outer bevel?
ACanvas.Brush.Color := clBtnShadow;
ACanvas.FrameRect(DrawRect);
{$IFDEF LDock}
InflateRect(DrawRect, -1, -1); //inner bevel?
//the value is not used any more!
{$ELSE}
{$ENDIF}
// draw caption
{$IFDEF LDock}
{$ELSE}
ACanvas.Font.Color := clFont; //clCaptionText;
{$ENDIF}
DrawRect := GetRectOfPart(ARect, AOrientation, zpCaption, AZone.HasSizer);
OldMode := SetBkMode(ACanvas.Handle, TRANSPARENT);
if AOrientation = doVertical then begin
DrawText(ACanvas.Handle, PChar(ACaption), -1, DrawRect, DT_LEFT or DT_SINGLELINE or DT_VCENTER)
end else begin
OldFont := 0;
if GetObject(ACanvas.Font.Reference.Handle, SizeOf(ALogFont), @ALogFont) <> 0 then
begin
ALogFont.lfEscapement := 900;
RotatedFont := CreateFontIndirect(ALogFont);
if RotatedFont <> 0 then
OldFont := SelectObject(ACanvas.Handle, RotatedFont);
end;
// from msdn: DrawText doesnot support font with orientation and escapement <> 0
TextOut(ACanvas.Handle, DrawRect.Left, DrawRect.Bottom, PChar(ACaption), Length(ACaption));
if OldFont <> 0 then
DeleteObject(SelectObject(ACanvas.Handle, OldFont));
end;
SetBkMode(ACanvas.Handle, OldMode);
// buttons - which colors to use?
{$IFDEF LDock}
{$ELSE}
ACanvas.Brush.Color := clBtnFace;
//ACanvas.Pen.Color := clButtonText;
{$ENDIF}
// draw close button
BtnRect := GetRectOfPart(ARect, AOrientation, zpCloseButton, AZone.HasSizer);
ACanvas.FillRect(BtnRect);
DrawButton(BtnRect, IsMouseDown, PtInRect(BtnRect, MousePos), DockBtnImages[dhiClose]);
{$IFDEF restore}
// draw restore button
BtnRect := GetRectOfPart(ARect, AOrientation, zpRestoreButton, AZone.HasSizer);
ACanvas.FillRect(BtnRect);
DrawButton(BtnRect, IsMouseDown, PtInRect(BtnRect, MousePos), DockBtnImages[dhiRestore]);
{$ENDIF}
end;