Can Delphi dragging be "promoted" to docking?

Question

I have a TPageControl whose pages are all various forms that are attached using ManualDock(). The user should be able to rearrange the tabs by dragging them, which works already. It should however also be possible to undock the docked forms.

For now I have the following code:

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.

Using the keys as modifiers is awkward though. Is there any way to cancel the active drag operation when the mouse cursor is outside of the tab area of the page control, and start docking the child form? This is with Delphi 2009.

Answer 1

I have a solution now which works for me, so I'll answer myself - maybe somebody has a use for this too.

Let's start with a small sample application that creates a TPageControl with 8 docked forms, with code to allow for runtime reordering of the tabs. Tabs will be moved live, and when the dragging is canceled the active tab index will revert to its original value:

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.

Paste this into the editor and run it, all necessary components and their properties will be created and set up at runtime.

Note that undocking the forms is possible only by double-clicking the tabs. It's also somewhat ugly that the drag cursor will be shown until the left mouse button is released, regardless of the distance from the tabs. It would be much better if the dragging was automatically canceled and the form be undocked instead, when the mouse is outside of the page control tab area with a few pixels margin.

This can be achieved by creating a custom DragObject in the OnStartDrag handler of the page control. In this object the mouse is captured, so all mouse messages while dragging can be handled in it. When the mouse cursor is outside of the tab influence rectangle the dragging is canceled, and a docking operation for the form in the active page control sheet is started instead:

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;

The class descends from TDragControlObjectEx instead of from TDragControlObject so that it will be automatically freed. Now if a handler for the TPageControl in the sample application is created (and set for the page control object):

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.