1

I got this code from the David's answer posted here and I adapted to my Delphi 2009. It's a nice and simple implementation of IDropTarget interface. Everything works fine, except that when I close the application I got "Invalid pointer operation" error. If I delete the Target.Free; line I no longer receive the error, but I guess that this is not the solution.

I am new to interfaces, I read some tutorials on the internet but I still can't understang why I'm getting that error.

DragAndDrop.pas

unit DragAndDrop;

interface

uses
  Windows, ActiveX, ShellAPI, StrUtils, Forms;

type

  TArrayOfString = array of string;

  TDropEvent = procedure(Sender:TObject; FileNames:TArrayOfString) of object;

  TDropTarget = class(TInterfacedObject, IDropTarget)
  private
    FHandle: HWND;
    FOnDrop: TDropEvent;
    FDropAllowed: Boolean;
    procedure GetFileNames(const dataObj: IDataObject; var FileNames: TArrayOfString);
    procedure SetEffect(var dwEffect: Integer);
    function DropAllowed(const FileNames:TArrayOfString): Boolean;

    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;
    property OnDrop:TDropEvent read FOnDrop write FOnDrop;
  end;

implementation

{ TDropTarget }

constructor TDropTarget.Create(AHandle: HWND);
begin
  inherited Create;
  FHandle:=AHandle;
  FOnDrop:=nil;
  RegisterDragDrop(FHandle, Self)
end;

destructor TDropTarget.Destroy;
begin
  RevokeDragDrop(FHandle);
  inherited;
end;

// the rest doesn't matter...

Unit1.pas

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, DragAndDrop, StdCtrls;

type
  TForm1 = class(TForm)
    Memo1: TMemo;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
   Target:TDropTarget;
   procedure OnFilesDrop(Sender:TObject; FileNames:TArrayOfString);
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
begin
 Target:=TDropTarget.Create(Memo1.Handle);
 Target.OnDrop:=OnFilesDrop;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
 Target.Free;
end;

procedure TForm1.OnFilesDrop(Sender: TObject; FileNames: TArrayOfString);
var x:Integer;
begin
 for x:=0 to High(FileNames) do
  Memo1.Lines.Add(FileNames[x]);
end;
Community
  • 1
  • 1
Marus Gradinaru
  • 2,824
  • 1
  • 26
  • 55
  • It should be `Target: IDropTarget;` – Dalija Prasnikar Jul 09 '15 at 18:27
  • That is true. However, by making that change, you do lose access to assign the `OnDrop` event, since it is not a member of `IDropTarget`. So you need to first create the `TDropTarget` object and assign it to a `TDropTarget` variable so you can then assign its event handler, and then assign the object to a `IDropTarget` variable to manage the refcount. To help side-step that issue, you could pass the `OnDrop` handler as a parameter to the `TDropTarget` constructor instead. – Remy Lebeau Jul 09 '15 at 18:31
  • Remy meant that your `TDropTarget` class' constructor would have a `TDropEvent` parameter where you would pass your form's `OnFilesDrop` event method. Doing so would allow you to declare `Target` as `IDropTarget`. – TLama Jul 09 '15 at 18:40
  • But how can I declare `Target` as `IDropTarget` and after that I instantiate it with `Target:=TDropTarget.Create(Memo1.Handle, OnFilesDrop);` I read that interfaces can't be instantiated. ..... And I guess that now I will not free the `Target` on `procedure TForm1.FormDestroy`... – Marus Gradinaru Jul 09 '15 at 18:46
  • You are not instantiating an interface, you are instantiating a class that implements the interface, and that is fine. You just need to assign the object to an interface variable instead of an object pointer variable so the interface reference count is managed correctly. – Remy Lebeau Jul 09 '15 at 19:02
  • 1
    @Marus, that assignment extracts the interface from the interfaced object. What you'll be holding in your variable is a reference to that interface. And that interfaced object instance you've created will be destroyed when the reference count of that interface reaches 0, which happens e.g. if you assign `nil` to that variable. So you can declare your `Target` as `IDropTarget`, instantiate as you've shown, and do nothing in destructor. – TLama Jul 09 '15 at 19:07

1 Answers1

3

Interfaces are reference counted, but your TForm1 is not playing by the reference counting rules correctly. And worse, TDropTarget is making an assumption that the lifetime of the HWND will outlive the lifetime of the TDropTarget object, and that is not guaranteed in VCL. Only TMemo knows when its own HWND is valid and when it is destroyed/recreated during the lifetime of the program. TDropTarget should not be managing its own registration, TMemo itself needs to manage that instead.

Try this:

unit DragAndDrop;

interface

uses
  Windows, ActiveX, ShellAPI, StrUtils;

type

  TArrayOfString = array of string;

  TDropEvent = procedure(FileNames: TArrayOfString) of object;

  TDropTarget = class(TInterfacedObject, IDropTarget)
  private
    FOnDrop: TDropEvent;
    FDropAllowed: Boolean;
    procedure GetFileNames(const dataObj: IDataObject; var FileNames: TArrayOfString);
    procedure SetEffect(var dwEffect: Integer);
    function DropAllowed(const FileNames:TArrayOfString): Boolean;

    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(AOnDrop: TDropEvent);
  end;

implementation

{ TDropTarget }

constructor TDropTarget.Create(AOnDrop: TDropEvent);
begin
  inherited Create;
  FOnDrop := AOnDrop;
end;

// the rest doesn't matter...

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, DragAndDrop, StdCtrls;

type
  TMemo = class(StdCtrls.TMemo)
  private
    Target: IDropTarget;
    FOnDrop: TDropEvent;
    procedure OnFilesDrop(FileNames: TArrayOfString);
  protected
    procedure CreateWnd; override;
    procedure DestroyWnd; override;
  public
    property OnDrop: TDropEvent read FOnDrop write FOnDrop;
  end;

  TForm1 = class(TForm)
    Memo1: TMemo;
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
    procedure OnFilesDrop(FileNames: TArrayOfString);
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TMemo.CreateWnd;
begin
  inherited CreateWnd;
  if Target = nil then
    Target := TDropTarget.Create(OnFilesDrop);
  RegisterDragDrop(Handle, Target);
end;

procedure TMemo.DestroyWnd;
begin
  RevokeDragDrop(Handle);
  inherited DestroyWnd;
end;

procedure TMemo.OnFilesDrop(FileNames: TArrayOfString);
begin
  if Assigned(FOnDrop) then FOnDrop(FileNames);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  Memo1.OnDrop := OnFilesDrop;
end;

procedure TForm1.OnFilesDrop(FileNames: TArrayOfString);
var
  x: Integer;
begin
  for x := Low(FileNames) to High(FileNames) do
    Memo1.Lines.Add(FileNames[x]);
end;
Remy Lebeau
  • 555,201
  • 31
  • 458
  • 770