Можно ли «перетащить» Delphi в док?

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

У меня есть решение, которое работает для меня, поэтому я отвечу себе - может быть, кто-то тоже использует это.

Давайте начнем с небольшого примера приложения, которое создает 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 в обработчике 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;

, тогда перетаскивание вкладок будет отменено, когда мышь отодвинется достаточно далеко от вкладок, и если активная страница представляет собой закрепляемую форму, то будет начата операция закрепления для нее, которую все еще можно отменить с помощью ESC ключ.