¿Se puede "impulsar" el arrastre de Can Delphi al acoplamiento?

Question

Tengo un TPageControl cuyas páginas son todas las formas que se adjuntan usando ManualDock(). El usuario debería poder reorganizar las pestañas arrastrándolas, lo cual ya funciona. Sin embargo, también debería ser posible desacoplar los formularios acoplados.

Por ahora Tengo el siguiente código:

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; 

Si bien el Shift o la tecla Ctrl se mantienen bajos, a continuación, se iniciará una operación de acoplamiento, de lo contrario las pestañas se pueden reordenar por arrastrándolos.

Sin embargo, usar las teclas como modificadores es incómodo. ¿Hay alguna manera de cancelar la operación de arrastre activa cuando el cursor del mouse está fuera del área de pestañas del control de página y comenzar a acoplar el formulario hijo? Esto es con Delphi 2009.

Answer 1

Ahora tengo una solución que me funciona, así que me responderé a mí mismo, tal vez alguien también tenga un uso para esto.

Comencemos con una pequeña aplicación de muestra que crea un TPageControl con 8 formularios acoplados, con código para permitir el reordenamiento en tiempo de ejecución de las pestañas. Las pestañas se pueden mover en vivo, y cuando el arrastre se cancela el índice pestaña activa volverá a su valor original:

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. 

pega esto en el editor y ejecutarlo, todos los componentes necesarios y sus propiedades serán creados y configurar hasta en tiempo de ejecución.

Tenga en cuenta que es posible deshacer los formularios solo haciendo doble clic en las pestañas. También es algo desagradable que el cursor de arrastre se muestre hasta que se suelte el botón izquierdo del mouse, independientemente de la distancia desde las pestañas. Sería mucho mejor si el arrastre se cancelara automáticamente y el formulario fuera desacoplado en su lugar, cuando el mouse está fuera del área de la pestaña de control de página con un margen de algunos píxeles.

Esto se puede lograr mediante la creación de un DragObject personalizado en el controlador OnStartDrag del control de página. En este objeto, se captura el mouse, por lo que se pueden manejar todos los mensajes del mouse mientras se arrastra. Cuando el cursor del ratón se encuentra fuera de la influencia pestaña rectángulo el arrastre se cancela, y se inicia una operación de acoplamiento para la forma en la hoja de control de la página activa en su lugar:

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; 

La clase desciende de TDragControlObjectEx en lugar de desde TDragControlObject por lo que será liberado automáticamente Ahora bien, si se crea un controlador para el TPageControl en la aplicación de ejemplo (y ajustado para el objeto de control de página):

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; 

entonces el arrastre pestaña se cancelará cuando el ratón se mueve lo suficientemente lejos de las pestañas, y si la página activa es una forma acoplable y luego se iniciará una operación de acoplamiento, que aún se puede cancelar con la clave ESC.