Why does an instance of class(TInterfacedObject, IDropTarget) not auto free? - delphi

Question

I'm implementing my IDropTarget based on: How can I allow a form to accept file dropping without handling Windows messages?
The implementation by David works fine. however the IDropTarget (TInterfacedObject) object does not auto free, not even when set to 'nil'.
Part of the code is:
{ TDropTarget }
constructor TDropTarget.Create(AHandle: HWND; const ADragDrop: IDragDrop);
begin
inherited Create;
FHandle := AHandle;
FDragDrop := ADragDrop;
OleCheck(RegisterDragDrop(FHandle, Self));
//_Release;
end;
destructor TDropTarget.Destroy;
begin
MessageBox(0, 'TDropTarget.Destroy', '', MB_TASKMODAL);
RevokeDragDrop(FHandle);
inherited;
end;
...
procedure TForm1.FormShow(Sender: TObject);
begin
Assert(Panel1.HandleAllocated);
FDropTarget := TDropTarget.Create(Panel1.Handle, nil) as IDropTarget;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
FDropTarget := nil; // This should free FDropTarget
end;
var
NeedOleUninitialize: Boolean = False;
initialization
NeedOleUninitialize := Succeeded(OleInitialize(nil));
finalization
if (NeedOleUninitialize) then
OleUninitialize;
end.
where FDropTarget: IDropTarget;.
When I click the button no MessageBox is shown and the object is not destroyed.
If I call _Release; as suggested here at the end of the constructor, FDropTarget is destroyed when I click the button or when the program terminates (I have doubts about this "solution").
If I omit RegisterDragDrop(FHandle, Self), then FDropTarget is destroyed as expected.
I think the reference counting is broken for some reason. I'm really confused. How can I make the TInterfacedObject free correctly?
EDIT:
Here is the complete code:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
VirtualTrees, ExtCtrls, StdCtrls,
ActiveX, ComObj;
type
TDropTarget = class(TInterfacedObject, IDropTarget)
private
FHandle: HWND;
FDropAllowed: Boolean;
function GetTreeFromDataObject(const DataObject: IDataObject): TBaseVirtualTree;
procedure SetEffect(var dwEffect: Integer);
function DragEnter(const dataObj: IDataObject; grfKeyState: Integer; pt: TPoint; var dwEffect: Integer): HResult; stdcall;
function DragOver(grfKeyState: Longint; pt: TPoint; var dwEffect: Longint): HResult; stdcall;
function DragLeave: HResult; stdcall;
function Drop(const dataObj: IDataObject; grfKeyState: Longint; pt: TPoint; var dwEffect: Longint): HResult; stdcall;
public
constructor Create(AHandle: HWND);
destructor Destroy; override;
end;
TForm1 = class(TForm)
Panel1: TPanel;
VirtualStringTree1: TVirtualStringTree;
Button1: TButton;
procedure FormCreate(Sender: TObject);
procedure VirtualStringTree1DragAllowed(Sender: TBaseVirtualTree;
Node: PVirtualNode; Column: TColumnIndex; var Allowed: Boolean);
procedure Button1Click(Sender: TObject);
procedure FormShow(Sender: TObject);
private
FDropTarget: IDropTarget;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
{ TDropTarget }
constructor TDropTarget.Create(AHandle: HWND);
begin
inherited Create;
FHandle := AHandle;
OleCheck(RegisterDragDrop(FHandle, Self));
//_Release;
end;
destructor TDropTarget.Destroy;
begin
MessageBox(0, 'TDropTarget.Destroy', '', MB_TASKMODAL);
RevokeDragDrop(FHandle);
inherited;
end;
function TDropTarget.GetTreeFromDataObject(const DataObject: IDataObject): TBaseVirtualTree;
// Returns the owner/sender of the given data object by means of a special clipboard format
// or nil if the sender is in another process or no virtual tree at all.
var
Medium: TStgMedium;
Data: PVTReference;
formatetcIn: TFormatEtc;
begin
Result := nil;
if Assigned(DataObject) then
begin
formatetcIn.cfFormat := CF_VTREFERENCE;
formatetcIn.ptd := nil;
formatetcIn.dwAspect := DVASPECT_CONTENT;
formatetcIn.lindex := -1;
formatetcIn.tymed := TYMED_ISTREAM or TYMED_HGLOBAL;
if DataObject.GetData(formatetcIn, Medium) = S_OK then
begin
Data := GlobalLock(Medium.hGlobal);
if Assigned(Data) then
begin
if Data.Process = GetCurrentProcessID then
Result := Data.Tree;
GlobalUnlock(Medium.hGlobal);
end;
ReleaseStgMedium(Medium);
end;
end;
end;
procedure TDropTarget.SetEffect(var dwEffect: Integer);
begin
if FDropAllowed then begin
dwEffect := DROPEFFECT_COPY;
end else begin
dwEffect := DROPEFFECT_NONE;
end;
end;
function TDropTarget.DragEnter(const dataObj: IDataObject; grfKeyState: Integer; pt: TPoint; var dwEffect: Integer): HResult;
var
Tree: TBaseVirtualTree;
begin
Result := S_OK;
try
Tree := GetTreeFromDataObject(dataObj);
FDropAllowed := Assigned(Tree);
SetEffect(dwEffect);
except
Result := E_UNEXPECTED;
end;
end;
function TDropTarget.DragLeave: HResult;
begin
Result := S_OK;
end;
function TDropTarget.DragOver(grfKeyState: Integer; pt: TPoint; var dwEffect: Integer): HResult;
begin
Result := S_OK;
try
SetEffect(dwEffect);
except
Result := E_UNEXPECTED;
end;
end;
function TDropTarget.Drop(const dataObj: IDataObject; grfKeyState: Integer; pt: TPoint; var dwEffect: Integer): HResult;
var
Tree: TBaseVirtualTree;
begin
Result := S_OK;
try
Tree := GetTreeFromDataObject(dataObj);
FDropAllowed := Assigned(Tree);
if FDropAllowed then
begin
Alert(Tree.Name);
end;
except
Application.HandleException(Self);
end;
end;
{----------------------------------------------------------------------------------------------------------------------}
procedure TForm1.FormCreate(Sender: TObject);
begin
VirtualStringTree1.RootNodeCount := 10;
end;
procedure TForm1.VirtualStringTree1DragAllowed(Sender: TBaseVirtualTree;
Node: PVirtualNode; Column: TColumnIndex; var Allowed: Boolean);
begin
Allowed := True;
end;
procedure TForm1.FormShow(Sender: TObject);
begin
Assert(Panel1.HandleAllocated);
FDropTarget := TDropTarget.Create(Panel1.Handle) as IDropTarget;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
FDropTarget := nil; // This should free FDropTarget
end;
var
NeedOleUninitialize: Boolean = False;
initialization
NeedOleUninitialize := Succeeded(OleInitialize(nil));
finalization
if (NeedOleUninitialize) then
OleUninitialize;
end.
DFM:
object Form1: TForm1
Left = 192
Top = 114
Width = 567
Height = 268
Caption = 'Form1'
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Shell Dlg 2'
Font.Style = []
OldCreateOrder = False
OnCreate = FormCreate
OnShow = FormShow
PixelsPerInch = 96
TextHeight = 13
object Panel1: TPanel
Left = 368
Top = 8
Width = 185
Height = 73
Caption = 'Panel1'
TabOrder = 0
end
object VirtualStringTree1: TVirtualStringTree
Left = 8
Top = 8
Width = 200
Height = 217
Header.AutoSizeIndex = 0
Header.Font.Charset = DEFAULT_CHARSET
Header.Font.Color = clWindowText
Header.Font.Height = -11
Header.Font.Name = 'MS Shell Dlg 2'
Header.Font.Style = []
Header.MainColumn = -1
Header.Options = [hoColumnResize, hoDrag]
TabOrder = 1
TreeOptions.SelectionOptions = [toMultiSelect]
OnDragAllowed = VirtualStringTree1DragAllowed
Columns = <>
end
object Button1: TButton
Left = 280
Top = 8
Width = 75
Height = 25
Caption = 'Button1'
TabOrder = 2
OnClick = Button1Click
end
end
Conclusion:
From the docs:
RegisterDragDrop function also calls the IUnknown::AddRef method on
the IDropTarget pointer
The code in the answer I linked was fixed.
Note that reference counting on TDropTarget is suppressed. That is
because when RegisterDragDrop is called it increments the reference
count. This creates a circular reference and this code to suppress
reference counting breaks that. This means that you would use this
class through a class variable rather than an interface variable, in
order to avoid leaking.

Answer 1

The call to RegisterDragDrop in TDragDrop.Create passes a counted reference to the instance of the new instance of TDragDrop. That increases its reference counter. The instruction FDragDrop := Nil decreases the reference counter but there is still a reference to the object living that prevents the object from destroying itself.
You need to call RevokeDragDrop(FHandle) before you remove the last reference to that instance in order to get the reference counter down to zero.
In short: Calling RevokeDragDrop within the destructor is too late.