How to drag a thumbnail from JvtThumbview? - delphi

I am writing a WYSIWYG type of editor program in which the user can drag image thumbnails onto an editor surface (TPanel) and then create a PDF by rendering the editor surface onto the PDF.
On my TPanel, I have a TImage which the user can resize and move. I am using TSizeCtrl for this.
I have a TJvThumbview which is being loaded with images from a disk folder.
I want to accomplish drag-drop from the JvThumbview onto the TImage - but cannot do this.
Please can someone detail how I would accomplish this?
Thanks so much in advance.

I cannot resist.
My demo project consists of:
one TJvThumbView and
one TImage
Dragging is achieved by:
starting the drag operation when the user mouse-downs on the thumb view,
managing the dragged image by a TDragObject derivative,
drawing the dragged image when the drag object says the drag operation ended on the TImage.
This is how it could look like:
unit Unit1;
interface
uses
Classes, Graphics, Controls, Forms, JvExForms, JvBaseThumbnail, JvThumbViews,
ExtCtrls;
type
TMyDragObject = class(TDragControlObjectEx)
private
FDragImages: TDragImageList;
FPictureToDrag: TPicture;
protected
function GetDragImages: TDragImageList; override;
procedure Finished(Target: TObject; X, Y: Integer;
Accepted: Boolean); override;
public
constructor CreateFromThumbView(ThumbView: TJvThumbView);
destructor Destroy; override;
end;
TForm1 = class(TForm)
JvThumbView1: TJvThumbView;
Image1: TImage;
procedure FormCreate(Sender: TObject);
procedure JvThumbView1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure JvThumbView1StartDrag(Sender: TObject;
var DragObject: TDragObject);
procedure Image1DragOver(Sender, Source: TObject; X, Y: Integer;
State: TDragState; var Accept: Boolean);
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
begin
// Fill our image list with arbitrary images
if JvThumbView1.Directory = '' then
JvThumbView1.Directory := 'C:\Users\Public\Pictures\Sample Pictures';
// Style all controls for showing the drag image if Delphi version is D7 or
// lower. See also comment in TMyDragObject.CreateFromThumbView
JvThumbView1.ControlStyle := JvThumbView1.ControlStyle +
[csDisplayDragImage];
Image1.ControlStyle := Image1.ControlStyle + [csDisplayDragImage];
ControlStyle := ControlStyle + [csDisplayDragImage];
end;
procedure TForm1.Image1DragOver(Sender, Source: TObject; X, Y: Integer;
State: TDragState; var Accept: Boolean);
begin
// The destination image component accepts all drag operations
Accept := True;
end;
procedure TForm1.JvThumbView1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
// If mouse down on a thumb...
if JvThumbView1.SelectedFile <> '' then
// then let's start dragging
JvThumbView1.BeginDrag(False, Mouse.DragThreshold);
end;
procedure TForm1.JvThumbView1StartDrag(Sender: TObject;
var DragObject: TDragObject);
begin
// DragObject will automatically be destroyed when necessary when it's
// derived from TDragControlObjectEx
DragObject := TMyDragObject.CreateFromThumbView(JvThumbView1);
end;
{ TMyDragObject }
const
DragImageSize = 100;
constructor TMyDragObject.CreateFromThumbView(ThumbView: TJvThumbView);
begin
inherited Create(ThumbView);
// This is the picture the user will drag around
FPictureToDrag := TPicture.Create;
FPictureToDrag.LoadFromFile(ThumbView.SelectedFile);
// We want a nice drag image, but this property is only available in >D7
{ AlwaysShowDragImages := True; }
end;
destructor TMyDragObject.Destroy;
begin
FDragImages.Free;
FPictureToDrag.Free;
inherited Destroy;
end;
procedure TMyDragObject.Finished(Target: TObject; X, Y: Integer;
Accepted: Boolean);
begin
// Finished dragging
inherited Finished(Target, X, Y, Accepted);
// If we are over an Image component, then draw the picture
if Accepted and (Target is TImage) then
TImage(Target).Canvas.StretchDraw(Bounds(X, Y, DragImageSize,
DragImageSize), FPictureToDrag.Graphic);
end;
function TMyDragObject.GetDragImages: TDragImageList;
var
DragImage: TBitmap;
begin
if FDragImages = nil then
begin
FDragImages := TDragImageList.Create(nil);
// Set dimensions of drag image list
FDragImages.Width := DragImageSize;
FDragImages.Height := DragImageSize;
// Prepare drag image
DragImage:= TBitmap.Create;
try
DragImage.Width := DragImageSize;
DragImage.Height := DragImageSize;
DragImage.Canvas.StretchDraw(Rect(0, 0, DragImage.Width,
DragImage.Height), FPictureToDrag.Graphic);
FDragImages.AddMasked(DragImage, clWhite);
finally
DragImage.Free;
end;
end;
Result := FDragImages;
end;
end.

Related

Draw polygon on Image

I've been searching this quite a while but couldn't get the answer.
I want to draw a polygon on an image, but I want to do this with by creating points;
With the MouseCursor create this specific points, and with a button draw a line along these points;
I found this:
var
Poly: array of TPoint;
begin
// Allocate dynamic array of TPoint
SetLength(Poly, 6);
// Set array elements
Poly[0] := Point(10, 10);
Poly[1] := Point(30, 5);
Poly[2] := Point(100, 20);
Poly[3] := Point(120, 100);
Poly[4] := Point(50, 120);
Poly[5] := Point(10, 60);
// Pass to drawing routine
Canvas.Polygon(Poly);
// Redim if needed
SetLength(Poly, 7);
Poly[6] := Point(1, 5);
// Pass to drawing routine
Canvas.Polygon(Poly);
end;
This is what I want, but the difference is the Point[1], Point[2], etc is given by the user with a MouseEvent.
You might superimpose a Paintbox over your image and use a code like this
unit Unit3;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls, StdCtrls;
type
TPointArray=array of TPoint;
TForm3 = class(TForm)
Image1: TImage;
PaintBox1: TPaintBox;
Button1: TButton;
procedure PaintBox1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure PaintBox1Paint(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
{ Private-Deklarationen }
FPointArray:TPointArray;
public
{ Public-Deklarationen }
end;
var
Form3: TForm3;
implementation
{$R *.dfm}
procedure TForm3.Button1Click(Sender: TObject);
begin
PaintBox1.Visible := false;
Image1.Canvas.Polygon(FPointArray);
end;
procedure TForm3.PaintBox1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
SetLength(FPointArray,Length(FPointArray)+1);
FPointArray[High(FPointArray)].X := X;
FPointArray[High(FPointArray)].Y := Y;
Paintbox1.Invalidate;
end;
procedure TForm3.PaintBox1Paint(Sender: TObject);
var
i:Integer;
begin
PaintBox1.Canvas.Brush.Style := bsClear; //as suggested by TLama
PaintBox1.Canvas.Polygon(FPointArray);
for I := 0 to High(FPointArray) do
begin
PaintBox1.Canvas.TextOut(FPointArray[i].X-5,FPointArray[i].y-5,IntToStr(i));
end;
end;
end.
Make an array of points managed by your form. Declare a dynamic-array field in your form class:
private
FPoly: array of TPoint;
In your OnClick event, lengthen the array and append a new coordinate to it:
procedure TFruitForm.ImageClick(Sender: TObject);
var
p: TPoint;
begin
p := ...;
SetLength(FPoly, Length(FPoly) + 1);
FPoly[High(FPoly)] := p;
end;
To assign p, see How do I get the coordinates of the mouse when a control is clicked?
Instead of an array, you might also consider using a generic list: TList<TPoint>.

Moving images while drag and drop

I have an TImage on a TPanel, and an other (empty) TPanels. I want to drag
the image from the first to the second panel using the drag and drop.
I actually want to see the image while it's moving from one panel to the
other (semi-transparent).
I think I should use TDragObject.GetDragImages but I can't figure out how to construct the whole magic.
procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
Image1.ControlStyle := Image1.ControlStyle + [csDisplayDragImage]; // ???
TImage(Sender).BeginDrag(False);
end;
procedure TForm1.Image1StartDrag(Sender: TObject; var DragObject: TDragObject);
begin
// ???
end;
procedure TForm1.Panel1DragOver(Sender, Source: TObject; X, Y: Integer;
State: TDragState; var Accept: Boolean);
begin
if (Source is TImage) then
Accept := TImage(Source).Parent <> Sender;
end;
procedure TForm1.Panel1DragDrop(Sender, Source: TObject; X, Y: Integer);
begin
if (Source is TImage) then
begin
TImage(Source).Parent := TPanel(Sender);
TImage(Source).Align := alClient;
end;
end;
Update - I found a useful article: Implementing Professional Drag & Drop In VCL/CLX Applications
unit Unit3;
interface
// 2012 Thomas Wassermann - demo
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls;
type
TMyDragObject = class(TDragControlObject)
private
FImageList:TImageList;
FDragSource:TControl;
protected
function GetDragImages: TDragImageList; override;
public
Procedure StartDrag(G:TGraphic;p:TPoint;DragSource:TControl);
Constructor Create(AControl: TControl); override;
Destructor Destroy;override;
Property DragSource:TControl read FDragSource;
end;
TForm3 = class(TForm)
Panel1: TPanel;
Panel2: TPanel;
Image1: TImage;
procedure Image1StartDrag(Sender: TObject; var DragObject: TDragObject);
procedure FormCreate(Sender: TObject);
procedure Panel1DragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean);
procedure FormDestroy(Sender: TObject);
procedure Panel1DragDrop(Sender, Source: TObject; X, Y: Integer);
private
{ Private-Deklarationen }
FDragObject:TMyDragObject;
public
{ Public-Deklarationen }
end;
var
Form3: TForm3;
implementation
constructor TMyDragObject.Create(AControl: TControl);
begin
inherited;
FImageList:=TImageList.Create(nil);
end;
destructor TMyDragObject.Destroy;
begin
FImageList.Free;
inherited;
end;
function TMyDragObject.GetDragImages: TDragImageList;
begin
Result := FImageList;
end;
{$R *.dfm}
procedure TMyDragObject.StartDrag(G: TGraphic;p:TPoint;DragSource:TControl);
var
bmp:TBitMap;
begin
FDragSource := DragSource;
bmp:=TBitMap.Create;
try
FImageList.Width := g.Width;
FImageList.Height := g.Height;
bmp.Width := g.Width;
bmp.Height := g.Height;
bmp.Canvas.Draw(0,0,g);
FImageList.Add(bmp,nil);
finally
bmp.Free;
end;
FImageList.SetDragImage(0,p.x,p.y)
end;
procedure TForm3.FormCreate(Sender: TObject);
var
i:Integer;
begin
ControlStyle := ControlStyle + [csDisplayDragImage];
for I := 0 to ControlCount -1 do
if Controls[i] is TPanel then
TPanel(Controls[i]).ControlStyle := TPanel(Controls[i]).ControlStyle + [csDisplayDragImage];
ReportMemoryLeaksOnShutDown := True;
end;
procedure TForm3.FormDestroy(Sender: TObject);
begin
if Assigned(FDragObject) then FDragObject.Free;
end;
procedure TForm3.Image1StartDrag(Sender: TObject; var DragObject: TDragObject);
var
p:TPoint;
begin
p:=TImage(Sender).ScreenToClient(mouse.cursorpos);
if Assigned(FDragObject) then FDragObject.Free;
FDragObject := TMyDragObject.Create(TImage(Sender));
FDragObject.StartDrag(TImage(Sender).Picture.Graphic,p,TImage(Sender));
DragObject := FDragObject;
end;
procedure TForm3.Panel1DragDrop(Sender, Source: TObject; X, Y: Integer);
begin
if FDragObject.DragSource is TImage then
TImage(FDragObject.DragSource).Parent := TPanel(Sender);
end;
procedure TForm3.Panel1DragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean);
begin
Accept := Source is TMyDragObject;
end;
end.

TTreeView selection glitch while dragging a node

I'm implementing drag-and-drop functionality to a TTreeView. On a OnStartDrag Event of it, I'm creating the DragOcject of my derived class:
TTreeDragControlObject = class(TDragObject)
private
FDragImages: TDragImageList;
FText: String;
protected
function GetDragImages: TDragImageList; override;
end;
procedure TfrmMain.tvTreeStartDrag(Sender: TObject;
var DragObject: TDragObject);
begin
DragObject := TTreeDragControlObject.Create;
TTreeDragControlObject(DragObject).FText := tvTree.Selected.Text;
end;
And this is my override GetDragImages function of my DragObcject:
function TTreeDragControlObject.GetDragImages: TDragImageList;
var
Bmp: TBitmap;
begin
if FDragImages = nil then
begin
FDragImages := TDragImageList.Create(nil);
Bmp := TBitmap.Create;
try
Bmp.Width := Bmp.Canvas.TextWidth(FText) + 25;
Bmp.Height := Bmp.Canvas.TextHeight(FText);
Bmp.Canvas.TextOut(25, 0, FText);
FDragImages.Width := Bmp.Width;
FDragImages.Height := Bmp.Height;
FDragImages.SetDragImage(FDragImages.Add(Bmp, nil), 0, 0);
finally
Bmp.Free;
end;
end;
Result := FDragImages;
end;
Everything works fine except it has a painting glitch while dragging over the tree nodes:
How can I avoid this behavior?
Based on #Sean's and #bummi's answers I would post the entire code and conclusions that worked for me in D5.
On WinXP XPManifest is not a must - Hide/ShowDragImage are needed.
On Win7 XPManifest is needed. Hide/ShowDragImage are not a must.
Conclusion - use both XPManifest and HideDragImage and ShowDragImage to ensure TV will work both on XP/Win7.
type
TTreeDragControlObject = class(TDragControlObject)
private
FDragImages: TDragImageList;
FText: String;
protected
function GetDragImages: TDragImageList; override;
public
destructor Destroy; override;
procedure HideDragImage; override;
procedure ShowDragImage; override;
property DragText: string read FText write FText;
end;
TForm1 = class(TForm)
TreeView1: TTreeView;
procedure TreeView1StartDrag(Sender: TObject; var DragObject: TDragObject);
procedure TreeView1DragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean);
procedure TreeView1EndDrag(Sender, Target: TObject; X, Y: Integer);
private
FDragObject: TTreeDragControlObject;
public
end;
...
{ TTreeDragControlObject}
destructor TTreeDragControlObject.Destroy;
begin
FDragImages.Free;
inherited;
end;
procedure TTreeDragControlObject.HideDragImage;
begin
GetDragImages.HideDragImage;
end;
procedure TTreeDragControlObject.ShowDragImage;
begin
GetDragImages.ShowDragImage;
end;
function TTreeDragControlObject.GetDragImages: TDragImageList;
var
Bmp: TBitmap;
begin
if FDragImages = nil then
begin
FDragImages := TDragImageList.Create(nil);
Bmp := TBitmap.Create;
try
Bmp.Width := Bmp.Canvas.TextWidth(FText) + 25;
Bmp.Height := Bmp.Canvas.TextHeight(FText);
Bmp.Canvas.TextOut(25, 0, FText);
FDragImages.Width := Bmp.Width;
FDragImages.Height := Bmp.Height;
FDragImages.SetDragImage(FDragImages.Add(Bmp, nil), 0, 0);
finally
Bmp.Free;
end;
end;
Result := FDragImages;
end;
{ TForm1 }
procedure TForm1.TreeView1StartDrag(Sender: TObject; var DragObject: TDragObject);
begin
FDragObject := TTreeDragControlObject.Create(TTreeView(Sender));
FDragObject.DragText := TTreeView(Sender).Selected.Text;
DragObject := FDragObject;
end;
procedure TForm1.TreeView1DragOver(Sender, Source: TObject; X, Y: Integer;
State: TDragState; var Accept: Boolean);
begin
Accept := Source is TTreeDragControlObject;
end;
procedure TForm1.TreeView1EndDrag(Sender, Target: TObject; X, Y: Integer);
begin
FDragObject.Free;
end;
Note that in your code both FDragImages and var DragObject are leaking memory. I'd suggest using TDragControlObject instead of TDragObject (does your tvTreeEndDrag fire at all now? - it did not fire for me)
Using TXPManifest fixes this bug in D7.
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, XPMan, ComCtrls;
additional:
procedure Win7UpdateFix(Form: TForm; CharCode: Word);
var i: Integer;
begin
if Assigned(Form) and (Win32MajorVersion >= 6) and (Win32Platform = VER_PLATFORM_WIN32_NT) then //Vista, Win7
begin
case CharCode of
VK_MENU, VK_TAB: //Alt or Tab
begin
for i := 0 to Form.ComponentCount-1 do
begin
if Form.Components[i] is TWinControl then
begin
//COntrols that disappear - Buttons, Radio buttons, Checkboxes
if (Form.Components[i] is TButton)
or (Form.Components[i] is TRadioButton)
or (Form.Components[i] is TCheckBox) then
TWinControl(Form.Components[i]).Invalidate;
end;
end;
end;
end;
end;
end;
procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if key=VK_MENU then
begin
Win7UpdateFix(Self,key)
end;
end;
This same behaviour occurs in Delphi 2010 and TXPManifest does not fix it. By co-incidence I recently and independently came across this same problem in a Delphi 2010 application. The solution is to implement the HideDragImage()/ShowDragImage() methods like so ...
TTreeDragControlObject = class(TDragObject)
private
FDragImages: TDragImageList;
FText: String;
protected
function GetDragImages: TDragImageList; override;
public
procedure HideDragImage; override;
procedure ShowDragImage; override;
end;
... and then ...
procedure TTreeDragControlObject.HideDragImage;
begin
FDragImages.HideDragImage
end;
procedure TTreeDragControlObject.ShowDragImage;
begin
FDragImages.ShowDragImage
end;
The conseequence of this is that the windows API function ImageList_DragShowNolock() is called just before and after the drag image is painted ( via windows message TVM_SELECTITEM( TVGN_DROPHILITE)) . Without this function being called, the drag image is not properly painted. The need for ImageList_DragShowNolock(False/True) delimiting TVM_SELECTITEM+TVGN_DROPHILITE is a poorly documented feature, and if other forums are to judge, is a common cause for complaint.

Scroll TTreeView while dragging over/near the edges

I have a TTreeView that can have lots of nodes, when a lot of nodes are expanded the tree uses a lot of screen space.
Now suppose I want to drag a node that is near the bottom of the TreeView to the top, I can't physically see the top part of the TreeView because the node I am selecting is at the bottom. When dragging the node to the top of the TreeView I would like the TreeView to automatically scroll with me when dragging, by default this does not seem to happen.
A perfect example of this behaviour is seen in Windows Explorer. If you try to drag a file or folder, when you hover the dragged item (node) it automatically scrolls up or down depending on cursor position.
Hope that makes sense.
PS, I already know how to drag nodes, I want the TreeView to scroll with me when dragging if hovering near the top or bottom of the TreeView.
Thanks.
This is the code I use. It will work for any TWinControl descendent: list box, tree view, list view etc.
type
TAutoScrollTimer = class(TTimer)
private
FControl: TWinControl;
FScrollCount: Integer;
procedure InitialiseTimer;
procedure Timer(Sender: TObject);
public
constructor Create(Control: TWinControl);
end;
{ TAutoScrollTimer }
constructor TAutoScrollTimer.Create(Control: TWinControl);
begin
inherited Create(Control);
FControl := Control;
InitialiseTimer;
end;
procedure TAutoScrollTimer.InitialiseTimer;
begin
FScrollCount := 0;
Interval := 250;
Enabled := True;
OnTimer := Timer;
end;
procedure TAutoScrollTimer.Timer(Sender: TObject);
procedure DoScroll;
var
WindowEdgeTolerance: Integer;
Pos: TPoint;
begin
WindowEdgeTolerance := Min(25, FControl.Height div 4);
GetCursorPos(Pos);
Pos := FControl.ScreenToClient(Pos);
if not InRange(Pos.X, 0, FControl.Width) then begin
exit;
end;
if Pos.Y<WindowEdgeTolerance then begin
SendMessage(FControl.Handle, WM_VSCROLL, SB_LINEUP, 0);
end else if Pos.Y>FControl.Height-WindowEdgeTolerance then begin
SendMessage(FControl.Handle, WM_VSCROLL, SB_LINEDOWN, 0);
end else begin
InitialiseTimer;
exit;
end;
if FScrollCount<50 then begin
inc(FScrollCount);
if FScrollCount mod 5=0 then begin
//speed up the scrolling by reducing the timer interval
Interval := MulDiv(Interval, 3, 4);
end;
end;
if Win32MajorVersion<6 then begin
//in XP we need to clear up transient "fluff"; results in flickering so only do it in XP where it is needed
FControl.Invalidate;
end;
end;
begin
if Mouse.IsDragging then begin
DoScroll;
end else begin
Free;
end;
end;
Then to use it you add an OnStartDrag event handler for the control and implement it like this:
procedure TMyForm.SomeControlStartDrag(Sender: TObject; var DragObject: TDragObject);
begin
TAutoScrollTimer.Create(Sender as TWinControl);
end;
Here's an alternative based on the fact that the selected node always automatically scrolls in view.
type
TForm1 = class(TForm)
TreeView1: TTreeView;
TreeView2: TTreeView;
procedure TreeViewDragOver(Sender, Source: TObject; X, Y: Integer;
State: TDragState; var Accept: Boolean);
procedure TreeViewEndDrag(Sender, Target: TObject; X, Y: Integer);
procedure TreeViewMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
private
FDragNode: TTreeNode;
FNodeHeight: Integer;
end;
...
procedure TForm1.TreeViewMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
with TTreeView(Sender) do
begin
FDragNode := GetNodeAt(X, Y);
if FDragNode <> nil then
begin
Selected := FDragNode;
with FDragNode.DisplayRect(False) do
FNodeHeight := Bottom - Top;
BeginDrag(False, Mouse.DragThreshold);
end;
end;
end;
procedure TForm1.TreeViewDragOver(Sender, Source: TObject; X, Y: Integer;
State: TDragState; var Accept: Boolean);
var
Pt: TPoint;
DropNode: TTreeNode;
begin
Accept := Source is TTreeView;
if Accept then
with TTreeView(Source) do
begin
if Sender <> Source then
Pt := ScreenToClient(Mouse.CursorPos)
else
Pt := Point(X, Y);
if Pt.Y < FNodeHeight then
DropNode := Selected.GetPrevVisible
else if Pt.Y > (ClientHeight - FNodeHeight) then
DropNode := Selected.GetNextVisible
else
DropNode := GetNodeAt(Pt.X, Pt.Y);
if DropNode <> nil then
Selected := DropNode;
end;
end;
procedure TForm1.TreeViewEndDrag(Sender, Target: TObject; X, Y: Integer);
var
DropNode: TTreeNode;
begin
with TTreeView(Sender) do
if Target <> nil then
begin
DropNode := Selected;
DropNode := Items.Insert(DropNode, '');
DropNode.Assign(FDragNode);
Selected := DropNode;
Items.Delete(FDragNode);
end
else
Selected := FDragNode;
end;
You may want to link the OnDragOver event handler to the parent of the TreeView too, which results in scrolling ánd dropping when the mouse is outside the TreeView. If you dó want the scrolling, but not the dropping when the mouse is outside the TreeView, then check if Target = Sender in the OnEndDrag event handler.
Just to be complete, workarounds like in the other answers are not required anymore. Later versions have an option for this:
TreeOptions.AutoOptions.toAutoScroll := True

Can Delphi dragging be "promoted" to docking?

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.
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.

Resources