Delphi 高级停靠(Dock)技术的实现[转载]

转载：https://www.cnblogs.com/cxp2009/p/3270019.html

高级停靠(Dock)技术的实现

介绍

所谓停靠就是可以用鼠标拖动窗体或者控件，并将其从一个父窗体移出或者移动到另一个父窗体上，可以按水平，垂直方
向整齐排列， 并且可以停靠在分页控制组件上。下面的示意图是一个Delphi IDE的窗口停靠示意图：

clip_image001

考察一些常用的软件如Office等大型软件，会发现大多提供窗体停靠的功能。微软的MFC很早就引入了工具条的拖放功能，
可以将工具条上窗口上边拖放到窗口下边。而Borland则最早在Delphi 4中开始引入停靠功能支持，它实际上就是基于前
面我们讲到的VCL拖放技术基础之上的，后面我们会看到两者有多么的类似。Borland提供了停靠功能的一个演示程序，
可以在..DemosDocking目录下找到它，不过这个例子的问题就是太过复杂，使用了很多的高级技巧，不易理解。所以我
将抛开复杂的示例，一步一步的揭开停靠的秘密。

一个简单的停靠实现

工具条的停靠功能是最常见的功能需求，新建一个程序，在窗体上放置一个工具条，然后任意添加几个按钮，为了让工具条
能够从窗体上移出，最简单的办法是设定工具条的DragMode属性为dmAutomatic，将DragKind属性设定为dkDock。就像在拖
放类一章我们说的，DragMode设定为dmAutomatic表示当鼠标在工具条上点击并移动后，会自动发起拖放动作。而DragKind
为dkDock表示接下来的操作是一个停靠操作而不是普通的拖放操作。

运行这个简单的程序，然后拖放工具条，我们发现确实可以将工具条拖离主窗体使其变成一个浮动的工具条。注意在工具条
从窗体拖离时，VCL会在屏幕上画一个矩形表示工具条，我们称其为停靠图像。见下图：

clip_image002

可以看到，VCL强大的停靠支持使我们不用写一行代码就可以实现简单的停靠功能了，但是上面的程序存在几个问题：

1、 由于使用了dmAutomatic属性，哪怕是单击一下工具条不做任何拖动，都会使它变成浮动的工具条。

2、 拖离窗体后变成浮动的工具条无法停靠回原来的位置。

3、 浮动的工具条窗口可以被关闭，而关闭后再也没办法调出工具条了。

对于第一个问题，为了实现工具条在鼠标点击后，必须拖放几个像素后才能被拖离界面，可以像前面拖放类章节中所讲
的那样，设定工具条的DragMode为dmManual的手工模式，然后在工具条的OnMouseDown事件中使用拖放函数BeginDrag来发起
拖离的动作：

复制代码
procedure TForm1.ToolBar1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin

Toolbar1.BeginDrag(False);

end;
复制代码
1
2
浮动工具条能够被停靠回主界面，我们需要设定窗体的<font color="#0000ff">DockSite属性为True，表示窗体是一个停靠的锚点</font>，<font color="#0000ff">允许别的控件停靠在它上面。
</font>

而当关闭浮动工具条窗口时，VCL其实并没有销毁工具条，它只是将工具条的Visible属性设为False，使其不可见，为
了重新显示工具条，我们可以通过一个菜单命令，将其属性设为True。下面是添加的察看工具条的Action的代码，其中Update 事件判断工具条是否可见，如果不可见，则允许执行Action的OnExecute事件：

复制代码
procedure TForm1.ActionViewToolBarUpdate(Sender: TObject); 

begin 

(Sender as TAction).Enabled:=not Toolbar1.Visible; 

end; 

procedure TForm1.ActionViewToolBarExecute(Sender: TObject); 

begin 

Toolbar1.Visible:=True; 

end;
复制代码

再次运行修改后的停靠程序，多拖放停靠几次后，我们又会发现一个新的问题，那就是虽然浮动工具条可以被停靠回主界面

，但是位置不再是同界面顶部对齐，而是可以停靠在任意位置上，这显然不是我们想要的效果，什么原因造成的呢？怎么解

决呢？

原来，VCL在拖离任何控件后，都会将控件的Align属性修改为alNone，要想解决这个问题，就需要在工具条停靠在窗体上之
后将工具条的Align属性重新设定为alTop。幸好同拖放操作一样，在停靠组件时，VCL同样会产生一系列的事件，其中 OnEndDock事件会在停靠完成后发生，正好满足我们的需要，实现的工具条的OnEndDock事件如下：

复制代码
procedure TForm1.ToolBar1EndDock(Sender, Target: TObject; X, Y: Integer); 

begin 

Toolbar1.Align:=alTop; 

end;
复制代码

复杂界面的停靠

上面的停靠功能可以满足简单界面的需求了，那么考虑一个复杂的界面停靠操作。假设你的项目经理要求你在主界面上放置
两个面板，上面的面板上有一个工具条，下面的面板上也有一个工具条。两个面板上的工具条都停靠操作，但是有一个要求
是上面面板的工具条只能停靠在上面的面板上，同样下面的工具条也只能停靠在下面的面板上。

当组件在要停靠的组件上被拖动时，会调用被停靠组件的OnDockOver事件， OnDockOver的事件定义如下；

type TDockOverEvent = procedure(Sender: TObject; Source:

TDragDockObject; X, Y: Integer; State: TDragState; var Accept: Boolean) of object;

其中Source是一个VCL在停靠操作中自动创建的TDragDockObject类型的对象，它的Control属性就是停靠组件，所以可以在组
件的OnDockOver事件中根据要停靠的组件名称判断是否接收拖放。实现的判断代码如下：

复制代码
procedure TForm1.Panel1DockOver(Sender: TObject; Source: TDragDockObject; 

  X, Y: Integer; State: TDragState; var Accept: Boolean); 

begin 

Accept:=(Source.Control.Name='ToolBar1'); 

end; 

procedure TForm1.Panel2DockOver(Sender: TObject; Source: TDragDockObject; 

  X, Y: Integer; State: TDragState; var Accept: Boolean); 

begin 

Accept:=(Source.Control.Name='ToolBar2'); 

end;
复制代码

执行程序后，可以发现确实Toolbar1不会被停靠到Panel2上。但是有一个问题，虽然Panel2不接收Toolbar1的停靠，但是VCL
仍然会在修改Toolbar1的停靠矩形为Panel1的形状，在实际使用中可能会让用户产生一种错觉，以为可以停靠Toolbar1到
Panel2上。为了避免这种混乱，我们可以调整Source对象的DockRect以修改停靠矩形的显示，下面是调整矩形的代码：

复制代码
procedure TForm1.Panel2DockOver(Sender: TObject; Source: TDragDockObject; 

  X, Y: Integer; State: TDragState; var Accept: Boolean); 

begin 

Accept := (Source.Control.Name = 'ToolBar2'); 

if not Accept then 

Source.DockRect := AdjustDockRect(Sender, Source, X, Y); 

end; 

function TForm1.AdjustDockRect(Sender: TObject; Source: TDragDockObject; X, Y:Integer): TRect; 

var 

ARect: TRect; 

begin 

//将当前鼠标位置换算成屏幕坐标，赋值给矩形左上角 

ARect.TopLeft := (Sender as TWinControl).ClientToScreen(Point(X, Y)); 

//根据被拖放的工具条的尺寸计算出右下角坐标 

ARect.BottomRight := TWinControl(Sender).ClientToScreen( 

    Point(X + Source.Control.Width, Y + Source.Control.Height)); 

//最后根据鼠标拖动组件的部位计算出实际的矩形X,Y方向上的位移 

OffsetRect(ARect, 

    -Trunc(Source.Control.Width * Source.MouseDeltaX), 

    -Trunc(Source.Control.Height * Source.MouseDeltaY)); 

Result:=ARect; 

end;
复制代码

上面的代码过于烦琐，有没有更简单的办法呢？VCL会在DockOver事件前调用OnGetSiteInfo事件获得被停靠组件的信息，

同时返回一个CanDock参数表示是否接受停靠组件的停靠，事件定义如下：

type TGetSiteInfoEvent = procedure(Sender: TObject; DockClient: TControl; var InfluenceRect: TRect; 
MousePos: TPoint; var CanDock: Boolean) of object;

如果CanDock为False，则后面的DockOver就不会被调用了，也就无须修改工具条停靠矩形了。我们需要就是判断DockClient
的名称，决定是否允许拖放，代码如下：

复制代码
procedure TForm1.Panel1GetSiteInfo(Sender: TObject; DockClient: TControl; 

var InfluenceRect: TRect; MousePos: TPoint; var CanDock: Boolean); 

begin 

CanDock:=DockClient.Name='ToolBar1'; 

end; 

procedure TForm1.Panel2GetSiteInfo(Sender: TObject; DockClient: TControl; 

var InfluenceRect: TRect; MousePos: TPoint; var CanDock: Boolean); 

begin 

CanDock:=DockClient.Name='ToolBar2'; 

end;
复制代码

可以看到这种方式要比前一种方式简洁得多。

手工停靠

前面我们介绍的主要是通过鼠标的拖放动作来实现的组件的停靠，VCL还提供了ManualDock和ManualFloat过程来实现手工
Dock和UnDock的功能，将前面的简单停靠中切换工具条是否显示的菜单命令修改如下：

复制代码
procedure TForm1.ActionViewToolBarUpdate(Sender: TObject); 

begin 

  if (Toolbar1.Visible and not Toolbar1.Floating)then 

(Sender as TAction).Caption:='UnDock' 

else 

(Sender as TAction).Caption:='Dock'; 

end; 

procedure TForm1.ActionViewToolBarExecute(Sender: TObject); 

begin 

  if (Sender as TAction).Caption='Dock' then 

  begin 

Toolbar1.ManualDock(Form1, nil, alTop); 

//如果Dock的目标是窗体，必须加上下面两句话，如果是其它控件则不需要，这是VCL中//的一个bug 

    Toolbar1.Align:=alTop; 

    Toolbar1.Visible:=True; 

end 

  else 

Toolbar1.ManualFloat(Rect(Left, Top, Left + ToolBar1.UndockWidth, Top + ToolBar1.UndockHeight)); 

end;
复制代码

当Toolbar1的Floating属性为True时，表示它正处于浮动状态，我们可以进行停靠操作，反之则进行UnDock操作，使用
ManualDock时，需要指定停靠目标为Form1，对齐方式为alTop，注意至少在Delphi7中，将工具条手工停靠到窗体有问题
，无法看到正确的结果，必须在重新设定一下Visible和Align属性，但是如果停靠目标是面板等其它控件，则没有问题，
这应该是VCL中的bug。而使用ManualFloat使控件处于浮动状态时，需要指定浮动区域的矩形位置和大小，矩形的宽和高
对应于工具条的UndockWidth和UndockHeight属性。

管理停靠区域

凡是用过Word的人都知道，Word中的工具条的停靠能力非常强，不仅可以停靠在文字编辑器的顶部，还可以停靠在左边，
右边和下边，那么我们如果用VCL来模拟这一动作呢？一个比较简单的办法是在窗体的上下左右放上四个TPanel，设定它
们的DockSite属性为True就可以了，下面是新建一个项目，然后按下图示意添加面板：

clip_image003

面板的属性设置如下：

复制代码
object PanelTop: TPanel 

… 

Align = alTop 

DockSite = True 

end 

  object PanelLeft: TPanel 

… 

Align = alLeft 

DockSite = True 

  end 

object PanelRight: TPanel 

… 

Align = alRight 

DockSite = True 

end 

object PanelBottom: TPanel 

… 

Align = alBottom 

DockSite = True 

  end 

object PanelMain: TPanel 

… 

    Align = alClient 

  end
复制代码

放上一个工具条，设定工具条DragKind属性为dkDock，实现Toolbar1的OnMouseDown事件如下：

复制代码
procedure TForm1.ToolBar1MouseDown(Sender: TObject; Button: TMouseButton; 

  Shift: TShiftState; X, Y: Integer); 

begin 

Toolbar1.BeginDrag(False); 

end;
复制代码

运行程序，可以看到工具条确实可以在窗体的四周停靠，但是工具条始终是水平排布的，在停靠到左边时变成垂
直排布，所以我们要在拖放完成时，修改工具条的align属性，当组件在被停靠面板上释放时，会调用面板的OnDockDrop
事件，我们可以在该事件中修改工具条的属性。

新的问题又产生了，Word的停靠在上下左右都没有明显可见的停靠目标控件，而我们则使用了四个很明显的面板，为此要
修改面板的AutoSize属性为True，这样当没有控件在面板上时，将面板的宽或高调整为0，这样运行时，用户就看不到面
板了，同时虽然面板的尺寸变小了，但是VCL响应拖放的矩形区域其实是真实面板的尺寸在各个方向上都加上10个像素，所
以面板仍然能够响应工具条的拖放动作。再次运行程序，会发现程序运行的效果这回和Word几乎一模一样了。

但是，有点美中不足的是，由于面板在没有工具条时自动调整面板的大小，设定宽或高为0，这是显示的工具条的停靠矩形
跟缩小的面板尺寸进行匹配后画出来的就是一个非常狭长的矩形，视觉效果不佳。因为VCL是在停靠工具条在被停靠面板上
移动时画停靠矩形的，所以我们可以像前面那样在面板的OnDockOver事件中对DockRect进行处理，扩大矩形区域：

复制代码
procedure TForm1.PanelLeftDockOver(Sender: TObject; 

  Source: TDragDockObject; X, Y: Integer; State: TDragState; 

var Accept: Boolean); 

var 

DockBar: TToolBar; 

  InflateSize: Integer; 

  ARect: TRect; 

  ClientTL: TPoint; 

begin 

DockBar := Source.Control as TToolBar; 

//如果处于水平状态，获得工具条的高度，如果处于垂直状态，获得工具条的宽度 

if DockBar.Width > DockBar.Height then 

InflateSize := DockBar.Height 

else 

InflateSize := DockBar.Width; 

//将停靠矩形调整为工具条的尺寸 

ARect := Source.DockRect; 

case (Sender as TPanel).Align of 

alTop: Inc(ARect.Bottom, InflateSize); 

    alLeft: Inc(ARect.Left, InflateSize); 

    alBottom: Dec(ARect.Top, InflateSize); 

    alRight: Dec(ARect.Right, InflateSize); 

end; 

//由于界面布局的问题，必然有两个方向上的面板的矩形 

  //比窗体的实际尺寸要小,因为设计时，四个面板的尺寸 

  //不能完全占有占据整个窗体的垂直和水平方向 

  //所以接下来就是调整矩形区域，使其看起来好像是占据了整个窗体 

ClientTL := Point(0, 0); 

  ClientTL := ClientToScreen(ClientTL); 

case (Sender as TPanel).Align of 

alTop, alBottom: 

begin 

//使水平方向的矩形的宽度等于窗体的宽度 

ARect.Left := ClientTL.X; 

      ARect.Right := ClientTL.X + ClientWidth; 

end; 

    alLeft, alRight: 

begin 

//使垂直方向的矩形的高度等于窗体的高度 

ARect.Top := ClientTL.Y; 

      ARect.Bottom := ClientTL.Y + ClientHeight; 

end; 

end; 

  Source.DockRect := ARect 

end;
复制代码

调整前的效果：

clip_image004

调整后的效果：

clip_image005

分页停靠

在本文的第一个示意图上可以看到Delphi的IDE中除了普通的停靠组件排列外，还支持将各个窗口停靠在TPageControl
组件上，分页停靠，Code Explorer和BreakPoint List窗口同普通的停靠不一样，每当一个窗口停靠进CodeExplorer窗
口时，都会在TPageControl组件上新增一个页面，并将新的窗口停靠在页面上，实现子窗口的分页浏览。

要想实现这一功能非常简单，因为VCL的TPageControl组件重载了TWinControl组件的DoAddDockClient和DoRemoveDockClient
方法，能够自动响应停靠动作添加新的页面，而当浮动被停靠的窗口后将自动的将先前创建的TTabSheet页面删除，我们无须
写一行代码，只要设定基本的属性就可以实现分页停靠的功能。

新建一个项目，向窗体上放置一个TPageControl，设定DockSite属性为True。然后创建一个新的窗体，命名为TFormChild，
设定窗体的DragKind属性为dkDock，同样的，编写子窗体的OnMouseDown事件，通过BeginDrag方法发起停靠。然后再在主
窗体上添加一个菜单项，用来新建子窗体：

复制代码
var 

I:Integer; 

procedure TForm1.N1Click(Sender: TObject); 

var 

AForm:TFormChild; 

begin 

AForm:=TFormChild.Create(Application); 

  AForm.Caption:='ChildForm'+IntToStr(I); 

  Inc(I); 

  AForm.Show; 

end;
复制代码

运行程序，创建新的窗体，然后将窗体停靠到TPageControl上，可以看到每停靠一个新的窗体，PageControl就会新建一个
页面，每浮动一个窗体，就会删除先前的页面。示意图如下：

clip_image006

定制拖放图像

同拖放操作中类似，在停靠/浮动操作过程中，VCL也会创建一个TDragDockObject对象的实例，用来在停靠对象和停靠目标
之间传递信息。我们可以在OnStartDock事件中提供一个自定义的停靠对象，进而可以对停靠过程进行更为灵活的控制。停
靠对象基类TDragDockObject的类型定义如下：

复制代码
TDragDockObject = class(TBaseDragControlObject) 

… 

protected 

    procedure AdjustDockRect(ARect: TRect); virtual; 

procedure DrawDragDockImage; virtual; 

procedure EndDrag(Target: TObject; X, Y: Integer); override; 

procedure EraseDragDockImage; virtual; 

function GetDragCursor(Accepted: Boolean; X, Y: Integer): TCursor; override; 

function GetFrameWidth: Integer; virtual; 

public 

… 

property Brush: TBrush read FBrush write SetBrush; 

property DockRect: TRect read FDockRect write FDockRect; 

property DropAlign: TAlign read FDropAlign; 

property DropOnControl: TControl read FDropOnControl; 

property Floating: Boolean read FFloating write FFloating; 

property FrameWidth: Integer read GetFrameWidth; 

end;
复制代码

其中比较重要的可以重载的方法有GetDragCursor，VCL在做停靠操作时默认情况是不显示任何的拖放光标，而我们可以在停
靠过程中根据被停靠组件是否接受停靠组件来显示不同的拖放光标。下面举例说明，新建一个项目，在窗体上添加两个
TShape组件，一个TPanel，属性设置如下：

复制代码
object Shape1: TShape 

… 

    DragKind = dkDock 

    DragMode = dmAutomatic 

  end 

object Shape2: TShape 

… 

    DragKind = dkDock 

    DragMode = dmAutomatic 

Shape = stEllipse 

end 

object Panel1: TPanel 

… 

    Align = alRight 

DockSite = True 

  End 

object Panel2: TPanel 

… 

    Align = alLeft 

    DockSite = True 

  end
复制代码

定义一个新的TDockShapeObj的停靠类，类定义如下：

复制代码
TDockShapeObj=class(TDragDockObjectEx) 

protected 

    function GetDragCursor(Accepted: Boolean; X, Y: Integer): TCursor; override; 

end;
复制代码

注意，这里我们是从TDragDockObjectEx的基类派生出我们的自定义类，TDragDockObjectEx是从Delphi6开始引入到VCL的，
特点就是VCL会在停靠完成后自动释放它，无须手工释放。TDockShapeObj重载了GetDragCurosr方法，在停靠目标接受停靠
组件时时显示clip_image007光标，而在停靠目标不接受拖放时显示clip_image008光标。代码如下：

复制代码
function TDockShapeObj.GetDragCursor(Accepted: Boolean; X, 

  Y: Integer): TCursor; 

begin 

  if Accepted then 

result:=crDrag 

else 

result:=crNo; 

end; 

为了比较两者的区别，我们让Panel2不接受任何的拖放： 

procedure TForm1.Panel2DockOver(Sender: TObject; Source: TDragDockObject; 

  X, Y: Integer; State: TDragState; var Accept: Boolean); 

begin 

Accept:=False; 

end;
复制代码

在StartDock开始拖放时提供一个自定义的停靠对像

复制代码
procedure TForm1.Shape1StartDock(Sender: TObject;
  var DragObject: TDragDockObject);
var
  //自定义的停靠对象
  DragDockObject: TDockShapeObj;
begin
  DragDockObject := TDockShapeObj.Create(Sender as TControl);
  DragObject := DragDockObject;
end;
复制代码

运行程序，可以看到当将Shape1拖放到Panel1是显示的crDrag光标，而拖放到Panel2上时则显示crNo光标表示不接受停靠。

接下来我们看TDragDockObject还有另外两个重要的方法DrawDragDockImage和EraseDragDockImage，VCL在拖放时不停的调
用这两个方法在屏幕上画停靠图像和擦去停靠图像，默认的停靠图像总是一个灰色矩形方框，不是很美观，因此我们可以重
载这两个方法来实现自定义的停靠图像，比如对于Shape组件，我们想当Shape类型为圆形时，停靠图像也为圆形。下面就是
重载后的DrawDragDockImage和EraseDragDockImage方法：

复制代码
procedure TDockShapeObj.DrawDragDockImage; 

begin 

  if (Control is TShape) and (TShape(Control).Shape = stEllipse) then 

ShapeDockImage(False) 

else 

    inherited; 

end; 

procedure TDockShapeObj.EraseDragDockImage; 

begin 

  if (Control is TShape) and (TShape(Control).Shape = stEllipse) then 

ShapeDockImage(True) 

else 

    inherited; 

end; 

procedure TDockShapeObj.ShapeDockImage(Erase: Boolean); 

var 

DesktopWindow: HWND; 

  DC: HDC; 

  OldBrush: HBrush; 

  DrawRect: TRect; 

  OldBitmap: HBITMAP; 

begin 

DesktopWindow := GetDesktopWindow; 

  DC := GetDCEx(DesktopWindow, 0, DCX_CACHE or DCX_LOCKWINDOWUPDATE); 

try 

    if Erase then 

    begin 

DrawRect := FEraseDockRect; 

//恢复保存的背景 

BitBlt(DC, DrawRect.Left, DrawRect.Top, DrawRect.Right - 

        DrawRect.Left, DrawRect.Bottom - DrawRect.Top, THackPanel(Form1.Panel3).Canvas.Handle, 0, 0, 

        SRCCOPY); 

end 

    else 

    begin 

DrawRect := DockRect; 

FEraseDockRect := DockRect; 

//保存当前的矩形的背景 

BitBlt(THackPanel(Form1.Panel3).Canvas.Handle,0, 0, DrawRect.Right - DrawRect.Left, DrawRect.Bottom
        - DrawRect.Top, DC, DrawRect.Left, DrawRect.Top, SRCCOPY); 

//画椭圆 

OldBrush := SelectObject(DC, (Self.Control as TShape).Brush.Handle); 

      Windows.Ellipse(DC, DrawRect.Left, DrawRect.Top, DrawRect.Right, DrawRect.Bottom); 

      SelectObject(DC, OldBrush); 

end; 

finally 

ReleaseDC(DesktopWindow, DC); 

end; 

end;
复制代码

其中画图的原理就是先将要画图的矩形区域的位图保存起来，然后画椭圆，在擦除椭圆时，只要将原来保存的背景将现在的
背景覆盖一下就可以了。

定制浮动窗口

当我们双击Word中的被拖放出来的浮动的窗口的标题栏时，Word会自动将浮动的窗口停靠回原来的位置，这是一项很方便的
功能，可是VCL默认生成的浮动窗口却没有这项功能，需要我们自己来实现。

VCL中默认的浮动窗口是TCustomDockForm，它的类定义如下：

复制代码
TCustomDockForm = class(TCustomForm) 
… 
protected 
    procedure DoAddDockClient(Client: TControl; const ARect: TRect); override; 
procedure DoRemoveDockClient(Client: TControl); override; 
procedure GetSiteInfo(Client: TControl; var InfluenceRect: TRect; 
      MousePos: TPoint; var CanDock: Boolean); override; 

procedure Loaded; override; 
public 
   constructor Create(AOwner: TComponent); override; 
… 
end;
复制代码

要想实现停靠回原来的停靠锚点，我们要做的首先是重载DoAddClient方法，在添加停靠组件时，记录原来的停靠位置。
其次，我们要截获WM_NCLBUTTONDBLCLK消息响应标题栏双击事件。新的TOfficeDockForm实现如下：

复制代码
TOfficeDockForm=class(TCustomDockForm) 
private 
FOldSite:TWinControl; 
protected 
    procedure WMNCLButtonDown(var Message: TWMNCLButtonDown); message     WM_NCLBUTTONDOWN; 
    procedure DoAddDockClient(Client: TControl; const ARect: TRect); override; 
    procedure NCDblClick(var Msg: TWMNCLButtonDBLCLK);message WM_NCLBUTTONDBLCLK ; 
end; 
… 
procedure TOfficeDockForm.DoAddDockClient(Client: TControl; 
const ARect: TRect); 
begin 
    FOldSite:=TWinControl(Client.Tag); 
    inherited; 
end; 

procedure TOfficeDockForm.NCDblClick(var Msg: TWMNCLButtonDBLCLK); 
begin 
  if Msg.HitTest=htCaption then 
    DockClients[0].ManualDock(FOldSite); 
end; 

procedure TOfficeDockForm.WMNCLButtonDown(var Message: TWMNCLButtonDown); 
begin 
    //inherited; 
    DefaultHandler(message); 
end;
复制代码

上面代码中有几点要说明的是在DoAddClient方法中，我们是将添加的控件的Tag属性映射为它的前一个停靠锚点，前提是
因为VCL在停靠过程中并不保存原有被停靠组件的信息，所以在使用新的TOfficeDockForm前，我们必须在停靠组件的
OnStartDock时，手工将被停靠组件的信息绑定到停靠组件的Tag属性上。

另外，我们除了截获了窗口非客户区鼠标双击事件外，还截获了非客户区的鼠标单击事件，这是因为TCustomDockForm截获了
鼠标单击事件，做了如下处理：

复制代码
procedure TCustomDockForm.WMNCLButtonDown(var Message: TWMNCLButtonDown); 

begin 

  if (Message.HitTest = HTCAPTION) and (DragKind <> dkDock) and not 

(csDesigning in ComponentState) and not IsIconic(Handle) and 

(DockClientCount > 0) then 

  begin 

{ Activate window since we override WM_NCLBUTTON behavior } 

SetWindowPos(Handle, 0, 0, 0, 0, 0, SWP_NOZORDER or SWP_NOMOVE or 

SWP_NOSIZE); 

    PostMessage(Handle, WM_NCLBUTTONUP, TMessage(Message).WParam, 

TMessage(Message).LParam); 

    //如果客户单击窗口标题栏，则发起停靠 

if Active then DockClients[0].BeginDrag(True); 

end 

  else 

    inherited; 

end;
复制代码

问题是默认的处理是一旦客户单击了浮动窗口的标题栏，就发起停靠动作，但是发起停靠后鼠标双击标题栏事件就不会被
触发了。所以，我们在TOfficeDockForm中没有调用继承的TCustomDockForm的相应处理，而是调用DefaultHandler过程，
使用默认的消息处理方法来处理。

剩下的工作就是新建一个项目，在窗体上放上一个Button和两个面板，Button可以停靠在两个面板上，在窗体创建时，
将TOfficeDockForm的类类型赋值给Button的FloatingDockSiteClass属性，这样Button在创建浮动窗口时会自动使用我们的
TOfficeDockForm了：

复制代码
procedure TForm1.FormCreate(Sender: TObject); 
begin 
    Button1.ManualDock(Panel2); 
    Button1.FloatingDockSiteClass:=TOfficeDockForm; 
end; 

另外在每次停靠前，Button都要在OnStartDock事件中记录原来的停靠锚点的属性，以便TOfficeDockForm能够获得原来的停
靠位置信息。 

procedure TForm1.Button1StartDock(Sender: TObject; 
var DragObject: TDragDockObject); 
begin 
    Button1.Tag:=Integer(Button1.Parent); 
end;
复制代码

停靠管理器

在上面的例子中，可以注意到，当Button停靠到面板上时，会出现一个和Delphi的IDE完全一样的停靠窗体，上面是两条横
线，可以用来把Button拖出来(一般成为拖放把手)，右上角有一个小X是个关闭按钮，可以关闭Button，同时停靠更多的
Button时，它们会自动进行水平或者垂直排列。见下面示意图：

clip_image009

但是，我们使用窗体作为停靠锚点时却不会出现拖放把手和关闭按钮，而且停靠多个组件时，也不会自动排列，而是随意
排列，见下面的示意代码：

复制代码
… 

type 

TForm1 = class(TForm) 

procedure FormCreate(Sender: TObject); 

private 

… 

end; 

var 

Form1: TForm1; 

implementation 


{$R *.dfm} 


procedure TForm1.FormCreate(Sender: TObject); 

const 

Colors: array[1..6] of TColor = 

    (clWhite, clBlack, clBlue, clGreen, clRed, clYellow); 

var 

I: Integer; 

begin 

  for I := Low(Colors) to High(Colors) do 

    with TForm.CreateNew(Self) do 

    begin 

Caption := '停靠到主窗体'; 

      Color := Colors[I]; 

      DragKind := dkDock; 

      DragMode := dmAutomatic; 

      Position := poDefaultPosOnly; 

      Width := 230; 

      Height := 100; 

      Visible := True; 

end; 

end; 

end.
复制代码

在窗体的OnCreate事件中，我们创建了不同颜色的窗体，这些窗体可以被拖放进主窗体，拖放后效果如下：

clip_image010

那么为什么窗体的停靠效果和面板的不一样呢？接下来做个试验，将窗体的UseDockManager的属性设定为True，再次运行
程序，进行停靠，你会发现这回面板的停靠效果是一样的了。

clip_image011

打开Delphi的帮助，看一下UseDockManager属性的说明，可以知道当UseDockManager为True时，VCL使用一个停靠管理器
来管理停靠的动作，停靠管理器会处理停靠组件的排列关系以及绘画停靠把手和关闭按钮等等操作。VCL中内置了一个
TDockTree的类实现了停靠管理器的接口，提供了默认的停靠管理的实现，但是这个TDockTree有一点问题就是当管理多
个停靠组件时，它绘画停靠区域时经常会造成画面混乱，Delphi 4，5的IDE因为使用了TDockTree作为停靠管理器，导致
停靠工具条时，屏幕经常乱闪一气，工具条也经常会找不到，相信很多人都有过和我同样的不愉快经历，到了Delphi 6
、7之后，绘画混乱的情况有所好转，但是还是会有问题。那么一个简单的解决方案是在完成停靠后，调用DockManager
的ResetBounds方法重新计算停靠组件布局排列并重新绘制停靠区域：

复制代码
procedure TForm1.FormDockDrop(Sender: TObject; Source: TDragDockObject; X, 

  Y: Integer); 

begin 

DockManager.ResetBounds(True); 

end;
复制代码

美化停靠区域绘画

使用默认的停靠管理器可以很容易的实现高级的停靠效果，但是千人一面的效果用多了，难免让人厌倦，这也就是我猜
为什么微软每出一个新版Office的时候，都要把界面重新打造一遍的原因。对于默认的停靠管理器来说，我个人不喜欢
两条横线样式的停靠把手，希望是一条横线，同时希望在横线的旁边还能显示窗口的标题，要想实现自定义的停靠把手，
我们就需要提供一个自定义的停靠管理器来接管停靠区域的绘制工作。先来看默认停靠管理器TDockTree的类定义：

复制代码
TDockTree = class(TInterfacedObject, IDockManager) 

… 

protected 

    procedure AdjustDockRect(Control: TControl; var ARect: TRect); virtual; 

… 

procedure PaintDockFrame(Canvas: TCanvas; Control: TControl; 

const ARect: TRect); virtual; 

… 

end;
复制代码

其中在绘制停靠把手过程中TDockTree会调用AdjustDockRect来调整停靠区域的大小为把手和关闭按钮腾出绘制的空间来，
而PaintDockFrame则被用来绘制具体的横线和把手。由于默认的TDockTree留出的把手区域太窄，画出的字体不好看，所以
我们要重载AdjustDockRect方法扩大把手区域。而要实现绘制自定义的单条横线和标题，我们还需要重载PaintDockFrame
方法，下面是我们的新的停靠管理器的代码：

复制代码
TNewDockManager = class(TDockTree) 
protected 
    procedure PaintDockFrame(Canvas: TCanvas; Control: TControl; 
const ARect: TRect); override; 
    procedure AdjustDockRect(Control: TControl; var ARect: TRect); override; 
end; 
  THackControl = class(TControl); 
  … 
const 
GrabberSize = 20;//把手大小，这里定得大一些，为了使标题画出来好看些 

procedure TNewDockManager.AdjustDockRect(Control: TControl; 
var ARect: TRect); 
begin 

  if DockSite.Align in [alTop, alBottom] then 

inc(ARect.Left, GrabberSize) else 

inc(ARect.Top, GrabberSize); 

end; 

procedure TNewDockManager.PaintDockFrame(Canvas: TCanvas; 

  Control: TControl; const ARect: TRect); 

procedure DrawCloseButton(Left, Top: Integer); 

begin 

DrawFrameControl(Canvas.Handle, Rect(Left, Top, Left+GrabberSize-2, 

      Top+GrabberSize-2), DFC_CAPTION, DFCS_CAPTIONCLOSE); 

end; 

procedure DrawCaptionBar(Left, Top, Right, Bottom: Integer); 

begin 

Canvas.Brush.Color := clActiveCaption; 

    Canvas.FillRect(Rect(Left, Top, Right, Bottom)); 

end; 

procedure DrawCaptionText(const Text: String; Left, Top, Right, Bottom: Integer); 

begin 

Canvas.Font.Name := 'ËÎÌå'; 

    Canvas.Font.Color := clCaptionText; 

    Canvas.Font.Height := Succ(Top - Bottom); 

    Canvas.TextRect(Rect(Left, Top, Right, Bottom), Left, Top, Text); 

end; 

procedure DrawGrabberLine(Left, Top, Right, Bottom: Integer); 

begin 

    with Canvas do 

    begin 

Pen.Color := clBtnHighlight; 

      MoveTo(Right, Top); 

      LineTo(Left, Top); 

      LineTo(Left, Bottom); 

      Pen.Color := clBtnShadow; 

      LineTo(Right, Bottom); 

      LineTo(Right, Top-1); 

end; 

end; 

begin 

  with ARect do 

    if DockSite.Align in [alTop, alBottom] then 

    begin 

DrawCaptionBar(Left, Top, Left+GrabberSize-1, Bottom); 

//画横线 

DrawGrabberLine(Left+4, Top+GrabberSize+1, Left+6, Bottom-2); 

      DrawCloseButton(Left+1, Top+1); 

end 

    else 

    begin 

DrawCaptionBar(Left, Top, Right, Top+GrabberSize-1); 

//画标题 

      DrawCaptionText(THackControl(Control).Caption, 

        Left, Top, Right, Top+GrabberSize-2); 

      DrawGrabberLine(Left+Canvas.TextWidth(THackControl(Control).Caption)+4, Top+7, Right-GrabberSize-2, 
Top+9); 

      DrawCloseButton(Right-GrabberSize+2, Top+1); 

end; 

end;
复制代码

上面AdjustDockRect方法主要是根据窗口的对齐方式按不同方向扩大停靠区域大小，省出标题栏的空间来，这里我们留出
的把手大小为20，比较大，主要是为了画出的标题好看一些。至于绘制把手和关闭按钮，很多代码是从TDockTree的原代码
中复制过来的，除了增加了画标题文本和只画一条横线的处理外，其余的大同小异。

光有新的停靠管理器还不够，我们还需要让停靠窗体使用这个停靠管理器，因此要重载窗体的CreateDockManager方法来提
供我们定制的DockManager。

function TForm1.CreateDockManager: IDockManager;

begin

//创建新的DockManager的实例

if (DockManager = nil) and DockSite and UseDockManager then

Result := TNewDockManager.Create(Self)

else

Result := DockManager;

//设定双缓冲以减少屏幕闪烁

DoubleBuffered := DoubleBuffered or Assigned(Result);

end;

运行程序，欣赏一下我与众不同的审美眼光吧：

clip_image012

总结

总的来说，Borland提供的停靠功能是非常强大，而且很容易扩展，一点不足就是默认的停靠管理器有一些Bug，同时
界面绘制略显单调了一些，相关文档也比较少。希望通过这篇文章的介绍，大家可以以此为起点写出更为专业的停靠界面，
秀出真我的色彩来。

【推广】 免费学中医，健康全家人
原文地址：https://www.cnblogs.com/studycode/p/10114902.html