i got code david's answer posted here , adapted delphi 2009. it's nice , simple implementation of idroptarget interface. works fine, except when close application got "invalid pointer operation" error. if delete target.free; line no longer receive error, guess not solution.
i new interfaces, read tutorials on internet still can't understang why i'm getting 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; // 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 x:=0 high(filenames) memo1.lines.add(filenames[x]); end;
interfaces reference counted, tform1 not playing reference counting rules correctly. , worse, tdroptarget making assumption lifetime of hwnd outlive lifetime of tdroptarget object, , not guaranteed in vcl. tmemo knows when own hwnd valid , when destroyed/recreated during lifetime of program. tdroptarget should not managing own registration, tmemo needs manage 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; // 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 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) fondrop(filenames); end; procedure tform1.formcreate(sender: tobject); begin memo1.ondrop := onfilesdrop; end; procedure tform1.onfilesdrop(filenames: tarrayofstring); var x: integer; begin x := low(filenames) high(filenames) memo1.lines.add(filenames[x]); end; 
Comments
Post a Comment