我正在实现我的IDropTarget：
How can I allow a form to accept file dropping without handling Windows messages?
大卫的implementation工作得很好.但是IDropTarget(TInterfacedObject)对象不会自动释放,即使设置为’nil’也不会.
部分代码是：
{ 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.
其中FDropTarget：IDropTarget;.
如果我打电话给_Release; as suggested here在构造函数的末尾,当我点击按钮或程序终止时,FDropTarget被销毁(我对这个“解决方案”有疑问).
如果我省略RegisterDragDrop(FHandle,Self),则会按预期销毁FDropTarget.
我认为引用计数因某种原因被破坏了.我真的很困惑.如何正确释放TInterfacedObject？
编辑：
这是完整的代码：
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,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
结论：
From the docs：
RegisterDragDropfunction also calls the IUnknown::AddRef method on
the IDropTarget pointer
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.