Fixing Drag and Drop in a FireMonkey Tree View
I’ve been preparing to add some drag and drop support to MonkeyStyler, chiefly revolving around a couple of tree views. So, I set out to investigate drag/drop for a TTreeView. I figured the automatic drag/drop support wouldn’t be enough for me but I started with it to see how things worked, and what I’d need to adapt.
What I found wasn’t a pretty picture. The issues I found where:
* It takes two clicks to start a drag operation: one to select an item, another to pick it up ans start dragging QC 110783.
* You can’t drop onto another tree view if it the destination’s Selected = nil QC 110646.
* The built in code selects the wrong item when hovering or dropping unless the tree view’s Position is at (0,0) on the form QC 110721.
all of which make the built in support unusable.
And finally comes the enhancements I need to use for MonkeyStyler:
* The built in behaviour is to move a TTreeViewItem from one location to another but I also need to be able to manage the data structures behind the tree view.
* I want the ability to copy an item (and related back end data).
* I want to be able to move items other than TTreeViewItems (at present that means dragging an class from a palette and creating an instance of that class on dropping).
So I set about fixing the broken stuff and adding support for what I neeed.
The code attached to this post is a child component of TTreeView which reworks the default drag/drop behaviour to fix the issues above. Much of it is simply a cut/paste of the existing code with bug fixes added plus some rather nasty hacks to remove default behaviour and access a private field which is needed.
Behaviour of the new code is:
* Added an EnableDrag property which replaces the AllowDrag property. Set EnableDrag to True to switch on the dragging behaviour. Do not set both EnableDrag and AllowDrag to true. Indeed, don’t use AllowDrag at all, that will simply return you to the old two-clicks to drag behaviour.
* Added an OnDropItem event. If this is assigned then the event handler is solely responsible for handling any reparenting or other processing necessary when an item is dropped. The minimal code necessary to move an item would be (ignoring sanity checks):
TFMXObject(Item).Parent := TFMXObject(NewParent);
You can, of course, process the new item in any way you see fit.
The code at present is XE3 only. As and when I add XE2 support I’ll update the code and this post. The download includes a sample project with three tree views you can drag between. Uncomment the line to add an OnDropItem event handler to test that functionality.
Update 27/11/12 to fix OnChange event not firing.
Full source:
unit Solent.TreeView;
interface
uses FMX.TreeView, System.UITypes, System.Classes, FMX.Types, SYstem.Types;
type TDropItemEvent = procedure(Sender, NewParent, Item: TObject) of object;
type TSolentTreeView = class(TTreeView)
private
FEnableDrag: Boolean;
FOnDropItem: TDropItemEvent;
function GetDragItem: TTreeViewItem;
procedure SetDragItem(const Value: TTreeViewItem);
protected
MouseDownPoint: TPointF;
DragStartItem: TTreeViewItem;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Single);override;
procedure MouseMove(Shift: TShiftState; X, Y: Single);override;
procedure DoMouseLeave;override;
procedure DragOver(const Data: TDragObject; const Point: TPointF;var Accept: Boolean);override;
procedure DragDrop(const Data: TDragObject; const Point: TPointF);override;
procedure StartDrag;virtual;
//Hack: Use RTTI to get acces to the private FDragItem field
property DragItem: TTreeViewItem read GetDragItem write SetDragItem;
public
published
//Use EnableDrag instead of AllowDrag. Setting both to true will not be good.
property EnableDrag: Boolean read FEnableDrag write FEnableDrag;
//If OnDropItem is assigned, then no automatic reparenting will happen.
//It is entirely up to the handler to add/reparent/delete as necessary.
//(Note that a default drag/drop would simply by: TFMXObject(Item).Parent := TFMXObject(NewParent);
property OnDropItem: TDropItemEvent read FOnDropItem write FOnDropItem;
end;
procedure Register;
implementation
uses FMX.Platform, System.RTTI, FMX.Forms, FMX.Layouts;
const DragDelta = 5; //No of pixels to move the mouse before starting a drag operation
procedure Register;
begin
RegisterComponents('Solent', [TSolentTreeView]);
end;
{ TSolentTreeView }
type
THackControl = class(TControl);
TDragOver = procedure(const Data: TDragObject;const Point: TPointF; var Accept: Boolean) of object;
TDragDrop = procedure(const Data: TDragObject;const Point: TPointF) of object;
procedure TSolentTreeView.StartDrag;
var Data: TDragObject;
Bitmap: TBitmap;
P: TFMXObject;
DragDrop: IInterface;
begin
if EnableDrag and Assigned(DragStartItem) then
begin
DragDrop := TPlatformServices.Current.GetPlatformService(IFMXDragDropService);
if Assigned(DragDrop) then
begin
Data.Source := DragStartItem;
Data.Data := TValue.From<TObject>(Self);
P := Parent;
while Assigned(P) and not (P is TCommonCustomForm) do
P := P.Parent;
if Assigned(P) then
try
Bitmap := DragStartItem.MakeScreenShot;
IFMXDragDropService(DragDrop).BeginDragDrop(TCommonCustomForm(P), Data, Bitmap);
finally
Bitmap.Free;
end;
end;
DragStartItem := nil;
end;
end;
procedure TSolentTreeView.DoMouseLeave;
begin
inherited;
StartDrag;
end;
procedure TSolentTreeView.DragDrop(const Data: TDragObject;
const Point: TPointF);
var
Item: TTreeViewItem;
Allow: Boolean;
P: TPointF;
Proc: TDragDrop;
begin
//Inherited method from TCustomTreeView is broken.
//Parent of TCustomTreeView is TScrollBox.
//Hack our way over the inherited method to get to the one in TScrollBox
//Credit to Serg http://stackoverflow.com/users/246408/serg
TMethod(Proc).Code := @TScrollBox.DragDrop;
TMethod(Proc).Data := Self;
Proc(Data, Point);
if Assigned(DragItem) then
begin
THackControl(DragItem).DragLeave;
DragItem.RemoveFreeNotify(Self);
DragItem := nil;
end;
Item := ItemByPoint(Point.X, Point.Y);
if Not Assigned(Item) then
begin
// to root
Allow := True;
if Assigned(OnDragChange) then
OnDragChange(TTreeViewItem(Data.Source), nil, Allow);
if Allow then
begin
if Assigned(OnDropItem) then
OnDropItem(Self, Self, Data.Source)
else
TTreeViewItem(Data.Source).Parent := Self;
Realign;
end;
end
else
begin
Allow := True;
if Assigned(OnDragChange) then
OnDragChange(TTreeViewItem(Data.Source), Item, Allow);
if Allow then
begin
if not TTreeViewItem(Data.Source).isChild(Item) then
begin
if not Item.IsExpanded then
Item.IsExpanded := True;
if Assigned(OnDropItem) then
OnDropItem(Self, Item, Data.Source)
else
TTreeViewItem(Data.Source).Parent := Item;
Realign;
end;
end;
end;
end;
procedure TSolentTreeView.DragOver(const Data: TDragObject;
const Point: TPointF; var Accept: Boolean);
var Item: TTreeViewItem;
Proc: TDragOver;
begin
//Inherited method from TCustomTreeView is broken.
//Parent of TCustomTreeView is TScrollBox.
//Hack our way over the inherited method to get to the one in TScrollBox
//Credit to Serg http://stackoverflow.com/users/246408/serg
TMethod(Proc).Code := @TScrollBox.DragOver;
TMethod(Proc).Data := Self;
Proc(Data, Point, Accept);
Item := ItemByPoint(Point.X, Point.Y);
if (Item <> DragItem) then
begin
if Assigned(DragItem) then
begin
THackControl(DragItem).DragLeave;
DragItem.RemoveFreeNotify(Self);
end;
DragItem := Item;
if Assigned(DragItem) then
begin
DragItem.AddFreeNotify(Self);
THackControl(DragItem).DragEnter(Data, Point);
Accept := True;
end
else
Accept := False;
end
else
Accept := True;
if (DragItem <> nil) and (DragItem = Selected) then
Accept := False;
end;
function TSolentTreeView.GetDragItem: TTreeViewItem;
var C: TRTTIContext;
T: TRTTIType;
F: TRTTIField;
V: TValue;
begin
Result := nil;
C := TRTTIContext.Create;
T := C.GetType(ClassInfo);
if T <> nil then
begin
F := T.GetField('FDragItem');
if F <> nil then
begin
V := F.GetValue(Self);
Result := V.AsType<TTreeViewItem>;
end;
end;
C.Free;
end;
procedure TSolentTreeView.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
Y: Single);
var Item: TTreeViewItem;
begin
inherited;
if EnableDrag then
begin
DragStartItem := ItemByPoint(X, Y);
MouseDownPoint.X := X;
MouseDownPoint.Y := Y;
end
else
DragStartItem := nil;
end;
procedure TSolentTreeView.MouseMove(Shift: TShiftState; X, Y: Single);
begin
inherited;
if (abs(X-MouseDownPoint.X) > DragDelta) or (abs(Y-MouseDownPoint.Y) > DragDelta) then
StartDrag;
end;
procedure TSolentTreeView.SetDragItem(const Value: TTreeViewItem);
var C: TRTTIContext;
T: TRTTIType;
F: TRTTIField;
V: TValue;
begin
C := TRTTIContext.Create;
T := C.GetType(ClassInfo);
if T <> nil then
begin
F := T.GetField('FDragItem');
if F <> nil then
F.SetValue(Self, TValue.From<TTreeViewItem>(Value));
end;
C.Free;
end;
initialization
RegisterFMXClasses([TSolentTreeView]);
end.
Previous Comments
#2 from .(JavaScript must be enabled to view this email address) on April 07, 2013
Thanks for this. It’s fixed some issues I’ve been having too. I’ve been trying to work out how to force the solenttreeview to take on the default style of the form - as it seems that it doesn’t inherit this form the panel.
Any ideas how one would go about doing this?
#3 from .(JavaScript must be enabled to view this email address) on April 18, 2013
It should work as-is, but you could try explicitly setting StyleLookup to ‘TreeViewStyle’.
#1 from .(JavaScript must be enabled to view this email address) on January 15, 2013
Mike,
I’ve got to say I admire your perseverance with FireMonkey and QC!
Issues like this and some of the glitches I’ve found with standard components make me wonder if anyone can be really using FM2?
Thanks for sharing all your hard work anyway it’s much appreciated