Delphi 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)