DragOver implementation faulty

[martijntonies]

The current implementation of Drag/Drop (VCL style) seems faulty.

When an application uses a custom DragObject instead of having the drag "Source" be a pointer to the control that started the drag, the treeview hides this functionality.

A custom DragObject is used to add functionality and have the target control not test for individual controls, but use this added functionality when drag-dropping between (different) controls.

When deriving a custom DragObject from TBaseDragControlObject, the target control can access the original control too. But not with VirtualTree, see the code below: it explicitly tests for TBaseDragControlObject and then passes the control to the "DragOver" event, instead of the custom DragObject like other VCL controls do.

This means that when we want to use the custom drag object in the DragOver (or DragDrop) events of the tree view, all that information is gone, making the custom drag object usage useless...

Only when there's an "DragInternalObject" (see TControl.DoDragMsg and procedure DragInitControl in VCL.Controls), should the control be passed, as this means no custom drag object was used.

I believe that VirtualTree >tries< to check for a custom drag object in the .DoStartDrag method, but this only works when Source and Target are the same treeview instance, not when dragging from a different component or between virtual tree instances.

A user can decide to derive from BaseDragObject instead to avoid the issue with the current faulty implementation, but then looses information about the original source control.

`procedure TBaseVirtualTree.CMDrag(var Message: TCMDrag);

var
S: TObject;
ShiftState: Integer;
P: TPoint;
Formats: TFormatArray;
Effect: Integer;

begin
with Message, DragRec^ do
begin
S := Source;
Formats := nil;

// Let the ancestor handle dock operations.
if S is TDragDockObject then
  inherited
else
begin
  // We need an extra check for the control drag object as there might be other objects not derived from
  // this class (e.g. TActionDragObject).
  if not (tsUserDragObject in FStates) and (S is TBaseDragControlObject) then
    S := (S as TBaseDragControlObject).Control;

...
DragOver(S, ShiftState, TDragState(DragMessage), Pos, Effect);
...
`

[joachimmarder]

I have to admit that I never used the VCL flavor of drag&drop so far. @martijntonies: Can you tell me if this problem was introduced recently or if it existed for a long time?

[martijntonies]

I believe this problem to have existed for a while.

The trick would be to keep current behaviour, but fix it for people using descendants of TDragControlObject.

in VCL.Controls procedure DragInitControl, you can see the internal drag object being created.

I think that whenever a user (coder) creates a custom drag object, its classname is always different from strings 'TDragControlObject' and 'TDragControlObjectEx' (and 'TDragDockObject', 'TDragDockObjectEx'), because the user wants to add information to the drag object.

Perhaps the Tree could check for these classnames (not using the IS operator, but comparing the strings) and pass the Control when it's these strings (basically because DragInternalObject is TRUE then) and pass the drag object when it's not these strings?

This, I think, would result in the same behaviour as in TControl.DoDragMsg even without being able to use the unit private DragInternalObject flag.

What happens if CMDrag also checks for DragType = dtVCL? Cause I see that being used in StartDrag, but not anywhere else?

[joachimmarder]

I think that whenever a user (coder) creates a custom drag object, its classname is always different from strings 'TDragControlObject' and 'TDragControlObjectEx' (and 'TDragDockObject', 'TDragDockObjectEx'), because the user wants to add information to the drag object.

Perhaps the Tree could check for these classnames (not using the IS operator, but comparing the strings) and pass the Control when it's these strings (basically because DragInternalObject is TRUE then)

Looking at the source code in Vcl.Controls, DragInternalObject is only true if the drag object is an instance of the class TDragDockObjectEx. Is your suggestion to call inherited then?

[martijntonies]

I think that whenever a user (coder) creates a custom drag object, its classname is always different from strings 'TDragControlObject' and 'TDragControlObjectEx' (and 'TDragDockObject', 'TDragDockObjectEx'), because the user wants to add information to the drag object.
Perhaps the Tree could check for these classnames (not using the IS operator, but comparing the strings) and pass the Control when it's these strings (basically because DragInternalObject is TRUE then)

Looking at the source code in Vcl.Controls, DragInternalObject is only true if the drag object is an instance of the class TDragDockObjectEx. Is your suggestion to call inherited then?

No, that's incorrect, there's 2 "drag kinds" > drag and dock. Then there's a compiler directive IF DEFINED (CLR) that differs between the TDrag(Control/Dock)Object or TDrag(Control/Dock)ObjectEx variants.

Looking at TControl.DoDragMsg, I can see the code checking for IsDockOp too, with an IS operator, so that part seems easier and as virtual tree does, we can let that be handled by the ancestor.

Vcl.Controls in TControl.DoDragMsg:
S := Source; IsDockOp := S is TDragDockObject; if DragInternalObject and not IsDockOp then S := (S as TDragControlObject).Control;

current VirtualTrees in TBaseVirtualTree.CMDrag:
` S := Source;
Formats := nil;

// Let the ancestor handle dock operations.
if S is TDragDockObject then
  inherited
else
begin
  // We need an extra check for the control drag object as there might be other objects not derived from
  // this class (e.g. TActionDragObject).
  if not (tsUserDragObject in FStates) and (S is TBaseDragControlObject) then
    S := (S as TBaseDragControlObject).Control;`

Perhaps something along the lines of:
` S := Source;
Formats := nil;

// Let the ancestor handle dock operations.
if S is TDragDockObject then
  inherited
else
begin
  // We need an extra check for the control drag object as there might be other objects not derived from
  // this class (e.g. TActionDragObject).

// if not (tsUserDragObject in FStates) and (S is TBaseDragControlObject) then
// S := (S as TBaseDragControlObject).Control;
if (S.ClassName = TDragControlObject.ClassName) or (S.ClassName = TDragControlObjectEx.ClassName) then
S := (S as TBaseDragControlObject).Control;
`

Only use the Control, is the Source is the internal drag object, check this by checking the classname.

[joachimmarder]

I have now applied your suggested code change. Please review it.