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

        文章是很久前写的了，有一年多了吧，今天也来BLOG一下！

 

 

        前段时间在论坛里看了一篇关于剖析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)