Delphi拖拽能否“提升”为对接？

我有一个TPageControl其页面都是使用附加的各种形式ManualDock()。用户应该能够通过拖动选项卡来重新排列选项卡，这已经可以使用了。然而，也应该可以取消停靠的表单。

现在我有以下代码：

procedure TMainForm.PageControlMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if (Button = mbLeft) and (Shift * [ssShift, ssCtrl] = [])
    and PageControl.DockSite
  then begin
    PageControl.BeginDrag(False, 32);
  end;
end;

If either the Shift or the Ctrl key are held down, then a docking operation will be started, otherwise the tabs can be rearranged by dragging them.

不过，使用按键作为修饰符很尴尬。有没有办法在鼠标光标位于页面控件的选项卡区域之外时取消活动的拖动操作，并开始停靠子窗体？这是 Delphi 2009 的情况。

我现在有一个适合我的解决方案，所以我会回答自己 - 也许有人也有这个用途。

让我们从一个创建一个小示例应用程序开始TPageControl有 8 个停靠表单，带有允许运行时重新排序选项卡的代码。选项卡将实时移动，并且当取消拖动时，活动选项卡索引将恢复为其原始值：

unit uDragDockTest;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  ComCtrls;

type
  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
  private
    fPageControl: TPageControl;
    fPageControlOriginalPageIndex: integer;
    function GetPageControlTabIndex(APosition: TPoint): integer;
  public
    procedure PageControlDragDrop(Sender, Source: TObject; X, Y: Integer);
    procedure PageControlDragOver(Sender, Source: TObject; X, Y: Integer;
      AState: TDragState; var AAccept: Boolean);
    procedure PageControlEndDrag(Sender, Target: TObject; X, Y: Integer);
    procedure PageControlMouseDown(Sender: TObject; AButton: TMouseButton;
      AShift: TShiftState; X, Y: Integer);
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
const
  FormColors: array[1..8] of TColor = (
    clRed, clGreen, clBlue, clYellow, clLime, clMaroon, clTeal, clAqua);
var
  i: integer;
  F: TForm;
begin
  fPageControlOriginalPageIndex := -1;

  fPageControl := TPageControl.Create(Self);
  fPageControl.Align := alClient;
  // set to False to enable tab reordering but disable form docking
  fPageControl.DockSite := True;
  fPageControl.Parent := Self;

  fPageControl.OnDragDrop := PageControlDragDrop;
  fPageControl.OnDragOver := PageControlDragOver;
  fPageControl.OnEndDrag := PageControlEndDrag;
  fPageControl.OnMouseDown := PageControlMouseDown;

  for i := Low(FormColors) to High(FormColors) do begin
    F := TForm.Create(Self);
    F.Caption := Format('Form %d', [i]);
    F.Color := FormColors[i];
    F.DragKind := dkDock;
    F.BorderStyle := bsSizeToolWin;
    F.FormStyle := fsStayOnTop;
    F.ManualDock(fPageControl);
    F.Show;
  end;
end;

const
  TCM_GETITEMRECT = $130A;

function TForm1.GetPageControlTabIndex(APosition: TPoint): integer;
var
  i: Integer;
  TabRect: TRect;
begin
  for i := 0 to fPageControl.PageCount - 1 do begin
    fPageControl.Perform(TCM_GETITEMRECT, i, LPARAM(@TabRect));
    if PtInRect(TabRect, APosition) then
      Exit(i);
  end;
  Result := -1;
end;

procedure TForm1.PageControlDragDrop(Sender, Source: TObject; X, Y: Integer);
var
  Index: integer;
begin
  if Sender = fPageControl then begin
    Index := GetPageControlTabIndex(Point(X, Y));
    if (Index <> -1) and (Index <> fPageControl.ActivePage.PageIndex) then
      fPageControl.ActivePage.PageIndex := Index;
  end;
end;

procedure TForm1.PageControlDragOver(Sender, Source: TObject; X, Y: Integer;
  AState: TDragState; var AAccept: Boolean);
var
  Index: integer;
begin
  AAccept := Sender = fPageControl;
  if AAccept then begin
    Index := GetPageControlTabIndex(Point(X, Y));
    if (Index <> -1) and (Index <> fPageControl.ActivePage.PageIndex) then
      fPageControl.ActivePage.PageIndex := Index;
  end;
end;

procedure TForm1.PageControlEndDrag(Sender, Target: TObject; X, Y: Integer);
begin
  // restore original index of active page if dragging was canceled
  if (Target <> fPageControl) and (fPageControlOriginalPageIndex > -1)
    and (fPageControlOriginalPageIndex < fPageControl.PageCount)
  then
    fPageControl.ActivePage.PageIndex := fPageControlOriginalPageIndex;
  fPageControlOriginalPageIndex := -1;
end;

procedure TForm1.PageControlMouseDown(Sender: TObject; AButton: TMouseButton;
  AShift: TShiftState; X, Y: Integer);
begin
  if (AButton = mbLeft)
    // undock single docked form or reorder multiple tabs
    and (fPageControl.DockSite or (fPageControl.PageCount > 1))
  then begin
    // save current active page index for restoring when dragging is canceled
    fPageControlOriginalPageIndex := fPageControl.ActivePageIndex;
    fPageControl.BeginDrag(False);
  end;
end;

end.

将其粘贴到编辑器中并运行它，所有必需的组件及其属性将在运行时创建和设置。

请注意，只有双击选项卡才能取消停靠表单。这也有点难看，无论距选项卡的距离如何，拖动光标都会显示直到释放鼠标左键。当鼠标位于页面控制选项卡区域之外且有几个像素边距时，如果自动取消拖动并取消停靠表单，效果会更好。

这可以通过创建自定义来实现DragObject in the OnStartDrag页面控件的处理程序。在这个对象中，鼠标被捕获，因此拖动时的所有鼠标消息都可以在其中处理。当鼠标光标位于选项卡影响矩形之外时，拖动将被取消，并且会启动活动页面控制表中表单的停靠操作：

type
  TConvertDragToDockHelper = class(TDragControlObjectEx)
  strict private
    fPageControl: TPageControl;
    fPageControlTabArea: TRect;
  protected
    procedure WndProc(var AMsg: TMessage); override;
  public
    constructor Create(AControl: TControl); override;
  end;

constructor TConvertDragToDockHelper.Create(AControl: TControl);
const
  MarginX = 32;
  MarginY = 12;
var
  Item0Rect, ItemLastRect: TRect;
begin
  inherited;
  fPageControl := AControl as TPageControl;
  if fPageControl.PageCount > 0 then begin
    // get rects of first and last tab
    fPageControl.Perform(TCM_GETITEMRECT, 0, LPARAM(@Item0Rect));
    fPageControl.Perform(TCM_GETITEMRECT, fPageControl.PageCount - 1,
      LPARAM(@ItemLastRect));
    // calculate rect valid for dragging (includes some margin around tabs)
    // when this area is left dragging will be canceled and docking will start
    fPageControlTabArea := Rect(
      Min(Item0Rect.Left, ItemLastRect.Left) - MarginX,
      Min(Item0Rect.Top, ItemLastRect.Top) - MarginY,
      Max(Item0Rect.Right, ItemLastRect.Right) + MarginX,
      Max(Item0Rect.Bottom, ItemLastRect.Bottom) + MarginY);
  end;
end;

procedure TConvertDragToDockHelper.WndProc(var AMsg: TMessage);
var
  MousePos: TPoint;
  CanUndock: boolean;
begin
  inherited;
  if AMsg.Msg = WM_MOUSEMOVE then begin
    MousePos := fPageControl.ScreenToClient(Mouse.CursorPos);
    // cancel dragging if outside of tab area with margins
    // optionally start undocking the docked form (can be canceled with [ESC])
    if not PtInRect(fPageControlTabArea, MousePos) then begin
      fPageControl.EndDrag(False);
      CanUndock := fPageControl.DockSite and (fPageControl.ActivePage <> nil)
        and (fPageControl.ActivePage.ControlCount > 0)
        and (fPageControl.ActivePage.Controls[0] is TForm)
        and (TForm(fPageControl.ActivePage.Controls[0]).DragKind = dkDock);
      if CanUndock then
        fPageControl.ActivePage.Controls[0].BeginDrag(False);
    end;
  end;
end;

该类源自TDragControlObjectEx而不是来自TDragControlObject这样它就会自动释放。现在，如果处理程序TPageControl在示例应用程序中创建（并设置为页面控制对象）：

procedure TForm1.PageControlStartDrag(Sender: TObject;
  var ADragObject: TDragObject);
begin
  // do not cancel dragging unless page control has docking enabled
  if (ADragObject = nil) and fPageControl.DockSite then
    ADragObject := TConvertDragToDockHelper.Create(fPageControl);
end;

then the tab dragging will be canceled when the mouse moves far enough away from the tabs, and if the active page is a dockable form then a docking operation for it will be started, which can still be canceled with the ESC key.