Как пpинимать яpлыки пpи пеpетягивании их на контpол

Как пpинимать яpлыки пpи пеpетягивании их на контpол

tform1 = class(tform)
...
private
{ private declarations }
procedure wmdropfiles(var m: twmdropfiles); message wm_dropfiles;
...
end;

var
form1: tform1;

implementation

uses
strutils, shellapi, comobj, shlobj, activex;

procedure tform1.formcreate(sender: tobject);
begin
...
dragacceptfiles(handle, true);
...
end;

procedure tform1.formdestroy(sender: tobject);
begin
...
dragacceptfiles(handle, false);
...
end;

procedure tform1.wmdropfiles(var m: twmdropfiles);
var
hdrop: cardinal;
n: integer;
s: string;
begin
hdrop := m.drop;
n := dragqueryfile(hdrop, 0, nil, 0);
setlength(s, n);
dragqueryfile(hdrop, 0, pchar(s), n + 1);
dragfinish(hdrop);
m.result := 0;
fileopen(s);
end;

procedure tform1.fileopen(filename: string);
begin
if comparetext(extractfileext(filename), '.lnk') = 0 then
filename := resolveshortcut(application.handle, filename);
docname := extractfilename(filename);
caption := application.title + ' - ' + docname;
...
end;

function resolveshortcut(wnd: hwnd; shortcutpath: string): string;
var
obj: iunknown;
isl: ishelllink;
ipf: ipersistfile;
pfd: twin32finddataa;
begin
result := '';
obj := createcomobject(clsid_shelllink);
isl := obj as ishelllink;
ipf := obj as ipersistfile;
ipf.load(pwchar(widestring(shortcutpath)), stgm_read);
with isl do
begin
resolve(wnd, slr_any_match);
setlength(result, max_path);
getpath(pchar(result), length(result), pfd, slgp_uncpriority);
result := pchar(result);
end;
end;

Эта запись была добавлена в Вторник, 13 мая, 2008 - 6:05 В разделы Компоненты, Разное. Вы можете подписаться на получение новых комментариев RSS 2.0 feed. Both comments and pings are currently closed.