也谈VCL中DragDrop功能的底层实现

前段时间在论坛里看了一篇关于剖析VCL结构的文件，其中不少高手的开怀畅谈让小辈们心里感觉非常的痛快！看完余又觉得不能光看，也该将自己的心得拿出来与大家分享，于是就边夜翻看VCL源码，终于将VCL如何实现DragDrop功能的过程弄个“基本明白”，其中可能会有不当之处，再加上小弟的文学水平也只是初中毕业，有些地方也许会表达不当，但其意思也基本上八九不离十了，故也请大家开怀畅言、批评指正，都是为了进步嘛！哈哈……

虽然DragDock操作与DragDrop操作是密切相关，并且很大一部分操作是相同的，但本文暂且不讨论与DragDock有关的部分，留待下回分解或也给大家表现表现………………

一、与DragDrop操作相关的属性、事件、函数

VCL的DragDrop功能是在TControl类中现的，因此所有从TControl类派生出来的控件类者继承了这些属性、事件和函数，包括：

属性：DragCursor: Drag时的鼠标类型：（TCursor）;
DragKind: Drag的类型：(dkDrag, dkDock);
DragMode: Drag的方式：手动(dmManual）或自动（dmAutomatic);

事件：OnStartDrag：Drag开始事件；
OnDragOver： Drag经过某个控件；
OnDragDrop： Drag到某个控件并放开；
OnEndDrag： Drag动作结束；

函数：BeginDrag： 开始控件的Drag动作；
Dragging： 返回控件是否正被Dragging；
CancelDrag： 取消正在执行的Drag操作；
EndDrag： 结束正在执行的Drag操作，与CancelDrag不同，EndDrag允许操作指定是否产生Drop操作（由Drop参数决定）。

此外还有一些与DragDrop相关的函数，在随后的介绍中将逐一说明。

二、DragDrop操作产生与执行的过程

1、自动产生过程。

我们知道在控件上单击鼠标左键时便会产生WM_LBUTTONDOWN消息，TControl类的WinProc消息处理方法捕捉到该消息时，便判断控件的DragMode是否为dmAutomatic，即是否自动执行DragDrop操作，如果是则调用类保护函数BeginAutoDrag，立即进入DragDrop状态，详见下面代码：

procedure TControl.WndProc(var Message: TMessage);
begin
...
case Message.Msg of
WM_LBUTTONDOWN, WM_LBUTTONDBLCLK:
begin
if FDragMode = dmAutomatic then
begin
BeginAutoDrag; // 进行DragDrop操作
Exit;
end;
Include(FControlState, csLButtonDown);
end;
...
else ... end;
...
end;

procedure TControl.BeginAutoDrag;
begin
BeginDrag(Mouse.DragImmediate, Mouse.DragThreshold);
end;

从上面代码可知它只是简单的调用了BeginDrag函数，具体开始DragDrop是由BeginDrag函数执行的。

2、手动产生过程。

当DragMode为dmManual时，将由程序在代码中显式调用BeginDrag方法产生。如：

procedure TForm1.Panel1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
Panel1.BeginDrag(True, -1);
end;

3、BeginDrag函数

分析前请先留意在 Controls 单元中声明的几个全局变量：
var
DragControl: TControl; // 被Drag的控件
DragObject: TDragObject; // 管理整个DragDrop过程的TDragObject对象
DragInternalObject: Boolean; // TDragObject对象是否由内部创建
DragCapture: HWND; // 管理DragDrop过程的Wnd实例句柄
DragStartPos: TPoint; // Drag开始时的鼠标位置
DragSaveCursor: HCURSOR; // Drag开始的的鼠标类型
DragThreshold: Integer; // Drag操作延迟位置
ActiveDrag: TDragOperation; // 正在执行的Drag操作：(dopNone, dopDrag, dopDock);
DragImageList: TDragImageList; // Drag过程中代替鼠标显示的图像列表

BeginDrag的函数原型声明为：
procedure BeginDrag(Immediate: Boolean; Threshold: Integer = -1);

参数：
Immediate：是否直接进入DragDrop状态；
Threshold：若Immediate参数为False，当鼠标移动量超过Threshold给出的值时进入DragDrop状态；

且先看其实现代码：
procedure TControl.BeginDrag(Immediate: Boolean; Threshold: Integer);
var
P: TPoint;
begin
// DragDrop操作的对象不允许是窗体

if (Self is TCustomForm) and (FDragKind <> dkDock) then
raise EInvalidOperation.CreateRes(@SCannotDragForm);

// 前面提过暂且不讨论DragDock相关部分，所以对CalcDockSizes的函数调用不作分析。
CalcDockSizes;

// DragControl 不为 nil 或 Pointer($FFFFFFFF) 说明已经进入了DragDrop状态
// 这里的判断避免了递归调用

if (DragControl = nil) or (DragControl = Pointer($FFFFFFFF)) then
begin
DragControl := nil;

// 如果被Drag控件处于鼠标按下状态（如前面的手动产生方式）时应先清除其状态
//
if csLButtonDown in ControlState then
begin
GetCursorPos(P);
P := ScreenToClient(P);
Perform(WM_LBUTTONUP, 0, Longint(PointToSmallPoint(P)));
end;

{ 如果传递的Threshold变量小于0，则使用系统默认的值 }
if Threshold < 0 then
Threshold := Mouse.DragThreshold;

// 以Pointer($FFFFFFFF)为标志防止在BeginDrag中调用EndDrag
if DragControl <> Pointer($FFFFFFFF) then
DragInitControl(Self, Immediate, Threshold); // !!!!!!
end;

end;

在BeginDrag的最后一行代码，由TControl类转入全局函数DragInitControl中。函数DragInitControl、DragInit、DragTo、DragDone共同组成了DragDrop核心与VCL类的交互接口。

4、DragInitControl、DragInit函数

DragInitControl函数接收了BeginDrag函数的Immediate和Threshold参数，还多了一个Control参数，该参数但是被Drag的控件。下面来看DragInitControl函数的实现代码：

procedure DragInitControl(Control: TControl; Immediate: Boolean; Threshold: Integer);
var
DragObject: TDragObject;
StartPos: TPoint;
begin
DragControl := Control;
try
DragObject := nil;
DragInternalObject := False;
if Control.FDragKind = dkDrag then
begin
Control.DoStartDrag(DragObject); // 产生StartDrag事件
if DragControl = nil then Exit;
if DragObject = nil then
begin
DragObject := TDragControlObjectEx.Create(Control);
DragInternalObject := True;
end
end
else begin
... // DragDock控件部分
end;
DragInit(DragObject, Immediate, Threshold);
except
DragControl := nil;
raise;
end;
end;

DragInitControl函数只是简单地进行一些判断然后调用TControl的DoStartDrag函数（该函数产生的OnStartDrag事件）并创建TDragControlObjectEx对象，就直接进入了DragInit函数，也就是真正由VCL控件类进入DragDrop管理核心的部分。
TDragControlObjectEx的内部保存了被Drag的控件及执行DragDrop的所需的其他参数，该类的实现及内部功能我们稍候再介绍。

DragInit函数接收的实现代码：

procedure DragInit(ADragObject: TDragObject; Immediate: Boolean; Threshold: Integer);
begin
// 在全局变量中保存参数
DragObject := ADragObject;
DragObject.DragTarget := nil;
GetCursorPos(DragStartPos);
DragObject.DragPos := DragStartPos;
DragSaveCursor := Windows.GetCursor;

// !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

DragCapture := DragObject.Capture; // 启动DragDrop管理核心

// !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

DragThreshold := Threshold;

if ADragObject is TDragDockObject then
begin
... // DragDock控制部分
end
else begin
if Immediate then ActiveDrag := dopDrag // 直接进入DragDrop操作
else ActiveDrag := dopNone;
end;

// -> 以下部分可以忽略
DragImageList := DragObject.GetDragImages;
if DragImageList <> nil then
with DragStartPos do DragImageList.BeginDrag(GetDeskTopWindow, X, Y);
QualifyingSites := TSiteList.Create;
// <-

if ActiveDrag <> dopNone then DragTo(DragStartPos);
end;

到此，便完全由TDragControlObjectEx（由全局变量DragObject保存）控制整个DragDrop操作；当DragObject检测到鼠标移动消息（WM_MOUSEMOVE）时，便会调用DragTo函数；DragTo函数查找鼠标所在位置的VCL控件，并产生DragOver事件。

5、DragTo函数

procedure DragTo(const Pos: TPoint);

function GetDropCtl: TControl;
begin
...
end;

var
DragCursor: TCursor; //
Target: TControl; // 鼠标所在位置（Pos）的VCL控件
TargetHandle: HWND; // 控件的句柄
DoErase: Boolean; // 是否执行擦除背景操作
begin
// 只有当Drag操作为dopDrag或dopDock，或鼠标移动量大于Threshold(传递给BeginDrag的值)时，
// 才执行后面的操作
if (ActiveDrag <> dopNone) or (Abs(DragStartPos.X - Pos.X) >= DragThreshold) or
(Abs(DragStartPos.Y - Pos.Y) >= DragThreshold) then
begin

// 查找鼠标当前位置的VCL控件
Target := DragFindTarget(Pos, TargetHandle, DragControl.DragKind, DragControl);

// ->
// 如果尚未开始Drag，则初始化图像列表为Dragging状态
if (ActiveDrag = dopNone) and (DragImageList <> nil) then
with DragStartPos do DragImageList.BeginDrag(GetDeskTopWindow, X, Y);
// <-

if DragControl.DragKind = dkDrag then
begin
ActiveDrag := dopDrag;
DoErase := False; // Drag操作只改变鼠标形状，不需要迫擦除移动框的背景
end
else begin
...
end;

// 如果鼠标位置移动前后所在的VCL控件不同

if Target <> DragObject.DragTarget then
begin
DoDragOver(dmDragLeave); // 原来的控件产生DragOver(dmDragLeave[离开])事件
if DragObject = nil then Exit;
DragObject.DragTarget := Target;
DragObject.DragHandle := TargetHandle;
DragObject.DragPos := Pos;
DoDragOver(dmDragEnter); // 新位置的控件产生DragOver(dmDragEnter[进入])事件
if DragObject = nil then Exit;
end;

// 计算Drag的当前位置
DragObject.DragPos := Pos;
if DragObject.DragTarget <> nil then
DragObject.DragTargetPos := TControl(DragObject.DragTarget).ScreenToClient(Pos);

// 获取Drag操作的鼠标形状
// 注意GetDragCursor的参数，它的参数正在DragOver(dmDragMove[移动])事件的返回值
DragCursor := TDragObject(DragObject).GetDragCursor(DoDragOver(dmDragMove),
Pos.X, Pos.Y);

//-〉 可以暂时忽略
if DragImageList <> nil then
begin
if (Target = nil) or (csDisplayDragImage in Target.ControlStyle) then
begin
DragImageList.DragCursor := DragCursor;
if not DragImageList.Dragging then
DragImageList.BeginDrag(GetDeskTopWindow, Pos.X, Pos.Y)
else DragImageList.DragMove(Pos.X, Pos.Y);
end
else begin
DragImageList.EndDrag;
Windows.SetCursor(Screen.Cursors[DragCursor]);
end;
end;
// 〈-

Windows.SetCursor(Screen.Cursors[DragCursor]);

if ActiveDrag = dopDock then
begin
... // DragDock相关部分
end;
end;
end;

从代码中，我们可以看出DragTo函数的工作分为两个部分：一是判断是否已经进入了Drag状态中，否则检查是否满足进入Drag状态的条件；二是查找鼠标当前位置的VCL控件，判断鼠标前后位置所在的VCL控件，并产生相应的事件。

当DragObject检测到鼠标放开消息（WM_LBUTTONUP, WM_RBUTTONUP）或ESC键按下消息（CN_KEYDOWN + K_ESCAPE）时，调用DragDone函数结束Drag操作。

6、DragDone函数

DragDone函数接收一个Drop参数，该参数指明是否使目标控件产生DragDrop事件

procedure DragDone(Drop: Boolean);

// -> DragDock相关部分
function CheckUndock: Boolean;
begin
Result := DragObject.DragTarget <> nil;
with DragControl do
if Drop and (ActiveDrag = dopDock) then
if Floating or (FHostDockSite = nil) then
Result := True
else if FHostDockSite <> nil then
Result := FHostDockSite.DoUnDock(DragObject.DragTarget, DragControl);
end;
// <-

var
DockObject: TDragDockObject;
Accepted: Boolean; // 目标控件是否接受DragDrop操作
DragMsg: TDragMessage;
TargetPos: TPoint; //
ParentForm: TCustomForm;
begin
DockObject := nil;
Accepted := False;

// 防止递归调用
// 检查DragObject的Canceling属性，如为真则直接退出
if (DragObject = nil) or DragObject.Cancelling then Exit;

try
DragSave := DragObject; // 保存当前DragDrop控制对象
try
DragObject.Cancelling := True; // 设置Cancelling标志，表示正在执行DragDone操作
DragObject.FDropped := Drop; // 在目标控件上释放标志

// !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
DragObject.ReleaseCapture(DragCapture); // 停止DragDrop管理核心
// !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

if ActiveDrag = dopDock then
begin
... // DragDock相关部分
end;

// 取得Drag的位置
if (DragObject.DragTarget <> nil) and
(TObject(DragObject.DragTarget) is TControl) then
TargetPos := DragObject.DragTargetPos
else
TargetPos := DragObject.DragPos;

// 目标控件是否接受Drop操作
// 当Drag操作为dopDrag时，目标控件产生DoDragOver(dmDragLeave[离开])事件
// 若传递给DragDone的Drop参数为False时，Accepted恒为False
Accepted := CheckUndock and
(((ActiveDrag = dopDock) and DockObject.Floating) or
((ActiveDrag <> dopNone) and DoDragOver(dmDragLeave))) and
Drop;

if ActiveDrag = dopDock then
begin
... // DragDock相关操作
end
else begin
// ->
if DragImageList <> nil then DragImageList.EndDrag
else Windows.SetCursor(DragSaveCursor);
// <-
end;

DragControl := nil;
DragObject := nil;

if Assigned(DragSave) and (DragSave.DragTarget <> nil) then
begin
DragMsg := dmDragDrop; // 产生DragDrop事件
if not Accepted then　　　　　　// 如果Accepted为False，则不产生DragDrop事件
begin　　　　　　　　　　　　　 // 实际上在VCL中没有处理dmDragCancel的相关代码
DragMsg := dmDragCancel;　　　// 即dmDragCancel只是一个保留操作
DragSave.FDragPos.X := 0;
DragSave.FDragPos.Y := 0;
TargetPos.X := 0;
TargetPos.Y := 0;
end;
DragMessage(DragSave.DragHandle, DragMsg, DragSave,
DragSave.DragTarget, DragSave.DragPos);
end;
finally
// ->
QualifyingSites.Free;
QualifyingSites := nil;
// <-

if Assigned(DragSave) then
begin
DragSave.Cancelling := False;
DragSave.Finished(DragSave.DragTarget, TargetPos.X, TargetPos.Y, Accepted); // 产生EndDrag事件
end;

DragObject := nil;
end;
finally
DragControl := nil;
if Assigned(DragSave) and ((DragSave is TDragControlObjectEx) or (DragSave is TDragObjectEx) or
(DragSave is TDragDockObjectEx)) then
DragSave.Free;
ActiveDrag := dopNone;
end;
end;

至此，与DragDrop核心的接口函数已介绍完毕；我们留意到在这些几个函数中还调用了DragFindTarget、DoDragOver、DragMessage几个函数，这些函数的源码在Control.pas中，功能分别如下：

DragFindTarget：(const Pos: TPoint; var Handle: HWND; DragKind: TDragKind; Client: TControl): Pointer;
根据DragKind的类型查找Pos位置的VCL控件（由函数返回值返回），Handle返回控件的句柄。

DoDragOver：(DragMsg: TDragMessage): Boolean;
产生目标控件的DragOver事件。

DragMessage：(Handle: HWND; Msg: TDragMessage;
Source: TDragObject; Target: Pointer; const Pos: TPoint): Longint;
发送Drag相关的消息到Drag控件。

7、DragDrop管理核心

下面的部分将是DragDrop管理的核心部分介绍。先来看一直管理核心类的定义及继承关系：
TDragObject = class(TObject);
TDragObjectEx = class(TDragObject);
TBaseDragControlObject = class(TDragObject);
TDragControlObject = class(TBaseDragControlObject);
TDragControlObjectEx = class(TDragControlObject);

这里只对TDragObject类的DragDrop控制实现过程作详细介绍，其他部分及其他类的实现就不多作介绍。

在DragInit函数中有这么一句调用：
DragCapture := DragObject.Capture;

TDragObject.Capture调用AllocateHWND函数创建了一个内部不可见窗口（Delphi习惯上称为TPUtilWindow），并设置该窗口句柄为Capture窗口，以接收应用程序的所有鼠标和键盘输入消息，实现Drag控制。下面是其实现代码：

function TDragObject.Capture: HWND;
begin
Result := Classes.AllocateHWND(MainWndProc);
SetCapture(Result);
end;

与TDragObject.Capture对应，有一个TDragObject.ReleaseCapture函数，在DragDone有相应调用：
DragObject.ReleaseCapture(DragCapture);

TDragObject.Capture结束DragDrop控制，函数中首先释放系统的Capture句柄，并调用DeallocateHWND释放由AllocateHWND创建的窗口。

当调用WinAPI函数SetCapture将一个窗口（句柄）设置为Capture模式后，系统的所有鼠标、键盘输入消息都将发送到该窗口中，VCL的DragDrop操作便是基于这样的原理来实现的。当调用了TControl.BeginDrag函数后，随后的几个函数设置DragDrop操作所需的参数，并创建了一个这样的Capture窗口，直到这时，鼠标的按键一直是按下的，当Capture窗口接收到鼠标按键释放或ESC键按下的消息时，便结束了DragDrop操作。

我们再来看一下TDragObject的消息处理函数TDragObject.WndProc：

procedure TDragObject.WndProc(var Msg: TMessage);
var
P: TPoint;
begin
try
case Msg.Msg of

// 鼠标移动时调用DragTo函数，检查鼠标位置的VCL控件并产生相应的事件ss
WM_MOUSEMOVE:
begin
P := SmallPointToPoint(TWMMouse(Msg).Pos);
ClientToScreen(DragCapture, P);
DragTo(P);
end;

// 系统的Capture窗口改变或鼠标按键释放时结束DragDrop操作
WM_CAPTURECHANGED:
DragDone(False); // 取消Drag
WM_LBUTTONUP, WM_RBUTTONUP:
DragDone(True); // 结束Drag并产生DragDrop事件

// 当一个TPUtilWindow获得鼠标Capture时，Forms.IsKeyMsg向其发送所有的键盘消息,
// 但是这些键盘消息都加上了CN_BASE，变成了CN_KEYxxx
// 如果Ctrl键按下或释放，
CN_KEYUP:
if Msg.WParam = VK_CONTROL then DragTo(DragObject.DragPos);
CN_KEYDOWN:
begin
case Msg.WParam of
VK_CONTROL:
DragTo(DragObject.DragPos);
VK_ESCAPE:
begin
{ Consume keystroke and cancel drag operation }
Msg.Result := 1;
DragDone(False); // ESC键按下，取消Drag操作
end;
end;
end;
end;
except
if DragControl <> nil then DragDone(False);
Application.HandleException(Self);
end;
end;

8、小结

通过全文的介绍，可以总结出下图：

TControl.BeginDrag
|
DragInitControl --> { TDragObject.Create; }
|
DragInit --> { TDragObject.Capture; }
|
|---------->|
| TDragObject.WinProc ---> WM_MOUSEMOVE ===> DragTo
| | |
|----------<| |-> WM_CAPTURECHANGED ===> DragDone(False)
| |
DragDone |-> WM_LBUTTONUP, WM_RBUTTONUP ==> DragDone(True)
|
|-> CN_KEYUP(VK_CONTROL) ===> DragTo
|
|-> CN_KEYDOWN(VK_CONTROL) ===> DragTo
|
|-> CN_KEYDOWN(VK_ESCAPE) ===> DragDone(False)