为什么 class(TInterfacedObject, IDropTarget) 的实例不自动释放？

Question

我正在实施我的 IDropTarget 基于：How can I allow a form to accept file dropping without handling Windows messages?

David 的 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;.

当我点击按钮时，没有显示 MessageBox，对象也没有被销毁。

如果我在构造函数的末尾调用_Release; as suggested here，当我点击按钮或程序终止时FDropTarget被销毁（我对此有疑问"solution").

如果我省略 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, 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

结论： From the docs:

RegisterDragDrop function also calls the IUnknown::AddRef method on the IDropTarget pointer

the answer I linked 中的代码已修复。

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

在 TDragDrop.Create 中对 RegisterDragDrop 的调用传递了对 TDragDrop 新实例实例的计数引用。这增加了它的引用计数器。指令 FDragDrop := Nil 减少了引用计数器，但仍然存在对对象的引用，以防止对象销毁自身。您需要在删除对该实例的最后引用之前调用 RevokeDragDrop(FHandle) ，以便将引用计数器降为零。

简而言之：在析构函数中调用 RevokeDragDrop 为时已晚。

为什么 class(TInterfacedObject, IDropTarget) 的实例不自动释放？

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

delphi

delphi-5

tinterfacedobject