delphi - How to make my file DropSouce be accepted by all targets that works with files? -
i made control represents list of files , want able drag files control other applications work files. implemented idragsource interface (as shown below) when drag, files accepted windows explorer, other applications firefox, yahoo messenger, photoshop... not accept files. have done wrong ? have feeling idataobject not set correctly , i'm afraid have implemet myself... , coplicated job me because started work interfaces.
here code reproduce problem:
unit unit1; interface uses windows, messages, sysutils, variants, classes, graphics, controls, forms, dialogs, stdctrls, activex, shlobj; type tmycontrol = class(tmemo, idropsource) private function querycontinuedrag(fescapepressed:bool; grfkeystate:longint):hresult; stdcall; function givefeedback(dweffect:longint):hresult; stdcall; procedure dodraganddrop; function getfilelistdataobject:idataobject; protected procedure mousemove(shift:tshiftstate; x,y:integer); override; end; tform1 = class(tform) procedure formcreate(sender: tobject); public mymemo:tmycontrol; end; var form1: tform1; implementation {$r *.dfm} {tmycontrol} function tmycontrol.querycontinuedrag(fescapepressed:bool; grfkeystate:longint):hresult; begin if fescapepressed result:=dragdrop_s_cancel else if (grfkeystate , (mk_lbutton or mk_rbutton) = 0) result:=dragdrop_s_drop else result:=s_ok; end; function tmycontrol.givefeedback(dweffect:longint):hresult; begin result:=dragdrop_s_usedefaultcursors; end; procedure tmycontrol.dodraganddrop; var allowedeffects,dropeffect:longint; dataobj:idataobject; begin allowedeffects:=dropeffect_copy; dataobj:=getfilelistdataobject; if dataobj <> nil dodragdrop(dataobj, self, allowedeffects, dropeffect); end; function tmycontrol.getfilelistdataobject:idataobject; var desktop:ishellfolder; attr,eaten:ulong; count,x:integer; pidls:array of pitemidlist; begin result:=nil; count:=lines.count; if count<1 exit; if failed(shgetdesktopfolder(desktop)) exit; setlength(pidls,count); x:=0 count-1 pidls[x]:=nil; try x:=0 count-1 if failed(desktop.parsedisplayname(0, nil, pwidechar(lines[x]), eaten, pidls[x], attr)) exit; desktop.getuiobjectof(0, count, pidls[0], idataobject, nil, result); x:=0 count-1 if pidls[x]<>nil cotaskmemfree(pidls[x]); end; end; procedure tmycontrol.mousemove(shift:tshiftstate; x,y:integer); begin if ssleft in shift dodraganddrop; inherited; end; //--------------------------------- procedure tform1.formcreate(sender: tobject); begin mymemo:=tmycontrol.create(form1); mymemo.parent:=form1; mymemo.align:=alclient; end; end.
the problem use incorrect call of desktop.getuiobjectof. when call somefolder.getuiobjectof items must childs of somefolder. in case not true. try this:
type ppitemidlist = ^pitemidlist; function getfilelistdataobject(aparentwnd: hwnd; const apath: string; afilenames: tstrings): idataobject; var desktop: ishellfolder; eaten, attr: ulong; i: integer; pathidlist: pitemidlist; pathshellfolder: ishellfolder; idlists: ppitemidlist; idlistssize: integer; pos: ppitemidlist; begin result := nil; if afilenames.count < 1 exit; if failed(shgetdesktopfolder(desktop)) exit; try attr := 0; if failed(desktop.parsedisplayname(aparentwnd, nil, pwidechar(apath), eaten, pathidlist, attr)) exit; try if failed(desktop.bindtostorage(pathidlist, nil, ishellfolder, pathshellfolder)) exit; try idlistssize := sizeof(pitemidlist) * afilenames.count; getmem(idlists, idlistssize); try zeromemory(idlists, idlistssize); pos := idlists; := 0 afilenames.count - 1 begin attr := 0; if failed(pathshellfolder.parsedisplayname(0, nil, pwidechar(afilenames[i]), eaten, pos^, attr)) exit; inc(pos); end; pathshellfolder.getuiobjectof(0, afilenames.count, idlists^, idataobject, nil, result); pos := idlists; := 0 afilenames.count - 1 begin if assigned(pos^) cotaskmemfree(pos^); inc(pos); end; freemem(idlists); end; pathshellfolder := nil; end; cotaskmemfree(pathidlist); end; desktop := nil; end; end;
Comments
Post a Comment