I implement my IDropTarget based on: How can I allow a form to accept files without processing Windows messages?
The effect of David works great. however, the IDropTarget ( TInterfacedObject ) is not automatically freed, even if it is set to "nil".
Code Part:
{ 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 is FDropTarget: IDropTarget; .
When I click the button, the MessageBox is not displayed and the object is not destroyed.
If I call _Release; as suggested here at the end of the constructor, FDropTarget destroyed when I click the button or when the program terminates (I doubt this "decision").
If I omit RegisterDragDrop(FHandle, Self) , then the FDropTarget destroyed as expected.
I think link counting is for some reason broken. I'm really confused. How can I make 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 documents :
FunctionRegisterDragDrop also calls the IUnknown :: AddRef method IDropTarget pointer
Fixed the code in the answer that I linked .
Note that reference counting on TDropTarget is suppressed. That is because when RegisterDragDrop is called, it increases the count link. This creates a circular link and this code to suppress reference counting violates this. This means that you would use this class through a class variable, not an interface variable, in order to avoid leakage.