delphi - Delphi可以拖拽 "promoted"来对接吗？

Question

我有一个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;

如果按住 Shift 或 Ctrl 键，则会启动停靠操作，否则可以通过拖动来重新排列选项卡。

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

Answer 1

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

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

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.

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

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

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

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;

那么当鼠标移动距离选项卡足够远时，选项卡拖动将被取消，如果事件页面是可停靠表单，则将启动它的停靠操作，仍然可以使用 取消ESC 键。