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.TreeViewSystem.UITypesSystem.ClassesFMX.TypesSYstem.Types;

type TDropItemEvent procedure(SenderNewParentItemTObjectof object;

type TSolentTreeView = class(TTreeView)
  private
    
FEnableDragBoolean;
    
FOnDropItemTDropItemEvent;
    function 
GetDragItemTTreeViewItem;
    
procedure SetDragItem(const ValueTTreeViewItem);
  protected
    
MouseDownPointTPointF;
    
DragStartItemTTreeViewItem;
    
procedure MouseDown(ButtonTMouseButtonShiftTShiftStateXYSingle);override;
    
procedure MouseMove(ShiftTShiftStateXYSingle);override;
    
procedure DoMouseLeave;override;
    
procedure DragOver(const DataTDragObject; const PointTPointF;var AcceptBoolean);override;
    
procedure DragDrop(const DataTDragObject; const PointTPointF);override;
    
procedure StartDrag;virtual;
    
//Hack: Use RTTI to get acces to the private FDragItem field
    
property DragItemTTreeViewItem read GetDragItem write SetDragItem;
  public
  
published
    
//Use EnableDrag instead of AllowDrag. Setting both to true will not be good.
    
property EnableDragBoolean 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 OnDropItemTDropItemEvent read FOnDropItem write FOnDropItem;
  
end;

procedure Register;

implementation
uses FMX
.PlatformSystem.RTTIFMX.FormsFMX.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 DataTDragObject;const PointTPointF; var AcceptBooleanof object;
  
TDragDrop procedure(const DataTDragObject;const PointTPointFof object;

procedure TSolentTreeView.StartDrag;
var 
DataTDragObject;
  
BitmapTBitmap;
  
PTFMXObject;
  
DragDropIInterface;
begin
  
if EnableDrag and Assigned(DragStartItemthen
  begin
    DragDrop 
:= TPlatformServices.Current.GetPlatformService(IFMXDragDropService);
    if 
Assigned(DragDropthen
    begin
      Data
.Source := DragStartItem;
      
Data.Data := TValue.From<TObject>(Self);
      
:= Parent;
      while 
Assigned(P) and not (P is TCommonCustomForm) do
        
:= P.Parent;
      if 
Assigned(Pthen
      
try
        
Bitmap := DragStartItem.MakeScreenShot;
        
IFMXDragDropService(DragDrop).BeginDragDrop(TCommonCustomForm(P), DataBitmap);
      finally
        
Bitmap.Free;
      
end;
    
end;
    
DragStartItem := nil;
  
end;
end;

procedure TSolentTreeView.DoMouseLeave;
begin
  inherited
;
  
StartDrag;
end;

procedure TSolentTreeView.DragDrop(const DataTDragObject;
  const 
PointTPointF);
  var
  
ItemTTreeViewItem;
  
AllowBoolean;
  
PTPointF;
  
ProcTDragDrop;
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(DataPoint);

  if 
Assigned(DragItemthen
  begin
    THackControl
(DragItem).DragLeave;
    
DragItem.RemoveFreeNotify(Self);
    
DragItem := nil;
  
end;
  
Item := ItemByPoint(Point.XPoint.Y);
  if 
Not Assigned(Itemthen
  begin
    
// to root
    
Allow := True;
    if 
Assigned(OnDragChangethen
      OnDragChange
(TTreeViewItem(Data.Source), nilAllow);
    if 
Allow then
    begin
      
if Assigned(OnDropItemthen
        OnDropItem
(SelfSelfData.Source)
      else
        
TTreeViewItem(Data.Source).Parent := Self;
      
Realign;
    
end;
  
end
  
else
  
begin
    Allow 
:= True;
    if 
Assigned(OnDragChangethen
      OnDragChange
(TTreeViewItem(Data.Source), ItemAllow);
    if 
Allow then
    begin
      
if not TTreeViewItem(Data.Source).isChild(Itemthen
      begin
        
if not Item.IsExpanded then
          Item
.IsExpanded := True;
        if 
Assigned(OnDropItemthen
          OnDropItem
(SelfItemData.Source)
        else
          
TTreeViewItem(Data.Source).Parent := Item;
        
Realign;
      
end;
    
end;
  
end;
end;

procedure TSolentTreeView.DragOver(const DataTDragObject;
  const 
PointTPointF; var AcceptBoolean);
var 
ItemTTreeViewItem;
  
ProcTDragOver;
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(DataPointAccept);

  
Item := ItemByPoint(Point.XPoint.Y);
  if (
Item <> DragItemthen
  begin
    
if Assigned(DragItemthen
    begin
      THackControl
(DragItem).DragLeave;
      
DragItem.RemoveFreeNotify(Self);
    
end;
    
DragItem := Item;
    if 
Assigned(DragItemthen
    begin
      DragItem
.AddFreeNotify(Self);
      
THackControl(DragItem).DragEnter(DataPoint);
      
Accept := True;
    
end
    
else
      
Accept := False;
  
end
  
else
    
Accept := True;

  if (
DragItem <> nil) and (DragItem Selectedthen
    Accept 
:= False;
end;

function 
TSolentTreeView.GetDragItemTTreeViewItem;
var 
CTRTTIContext;
  
TTRTTIType;
  
FTRTTIField;
  
VTValue;
begin
  Result 
:= nil;
  
:= TRTTIContext.Create;
  
:= C.GetType(ClassInfo);
  if 
<> nil then
  begin
    F 
:= T.GetField('FDragItem');
    if 
<> nil then
    begin
      V 
:= F.GetValue(Self);
      
Result := V.AsType<TTreeViewItem>;
    
end;
  
end;
  
C.Free;
end;

procedure TSolentTreeView.MouseDown(ButtonTMouseButtonShiftTShiftStateX,
  
YSingle);
var 
ItemTTreeViewItem;
begin
  inherited
;
  if 
EnableDrag then
  begin
    DragStartItem 
:= ItemByPoint(XY);
    
MouseDownPoint.:= X;
    
MouseDownPoint.:= Y;
  
end
  
else
    
DragStartItem := nil;
end;

procedure TSolentTreeView.MouseMove(ShiftTShiftStateXYSingle);
begin
  inherited
;
  if (
abs(X-MouseDownPoint.X) > DragDelta) or (abs(Y-MouseDownPoint.Y) > DragDeltathen
    StartDrag
;
end;

procedure TSolentTreeView.SetDragItem(const ValueTTreeViewItem);
var 
CTRTTIContext;
  
TTRTTIType;
  
FTRTTIField;
  
VTValue;
begin
  C 
:= TRTTIContext.Create;
  
:= C.GetType(ClassInfo);
  if 
<> nil then
  begin
    F 
:= T.GetField('FDragItem');
    if 
<> nil then
      F
.SetValue(SelfTValue.From<TTreeViewItem>(Value));
  
end;
  
C.Free;
end;

initialization
  RegisterFMXClasses
([TSolentTreeView]);
end

 

Previous Comments

#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 smile

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

Commenting is not available in this channel entry.