Używam komponentu TFileDropper do pobierania (przeciągania) plików (do okna).
Jednak na systemie Windows 7 on już nie działa :/
Podejrzewam problem w procedurze: procedure TFileDropper.DropFile(Drop: HDROP);
unit Dropper;
{ TFileDropper }
{ Copyright ©1999 Lloyd Kinsella Software. }
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ShellApi;
type
TOnDrop = procedure (Sender: TObject; Filename: string) of object;
type
TFileDropper = class(TComponent)
private
FWndProcInstance: Pointer;
FDefProc: LongInt;
FDropSite: TWinControl;
FOnDrop: TOnDrop;
Finish: Boolean;
FAllowDir: Boolean;
FSubFolder: Boolean;
Lista: TstringList;
procedure WndProc(var Message: TMessage);
procedure DropFile(Drop: HDROP);
procedure Add(Path: string);
procedure AddFolder(Path: string);
function IsDirectory(Path: string): Boolean;
protected
function GetVersion: string;
procedure SetVersion(NewVersion: string);
procedure Loaded; override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property Wersja : string read GetVersion write SetVersion;
property DropSite: TWinControl read FDropSite write FDropSite;
property OnDrop: TOnDrop read FOnDrop write FOnDrop;
property AllowDir: Boolean read FAllowDir write FAllowDir;
property SubFolders: Boolean read FSubFolder write FSubFolder;
property Finished: Boolean read Finish write Finish;
end;
procedure Register;
implementation
constructor TFileDropper.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FAllowDir := False;
FSubFolder := False;
Finish := True;
Lista := TstringList.Create;
end;
destructor TFileDropper.Destroy;
begin
inherited Destroy;
Lista.Free;
end;
function TFileDropper.GetVersion: string;
begin
Result := 'FileDropper 1.1 (03.2006)';
end;
procedure TFileDropper.SetVersion(NewVersion: string);
begin
NewVersion := GetVersion;
end;
procedure TFileDropper.WndProc(var Message: TMessage);
begin
if Message.Msg = WM_DROPFILES then
begin
DropFile(Message.WParam);
Message.Result := 0;
end
else Message.Result := CallWindowProc(Pointer(FDefProc),FDropSite.Handle, Message.Msg, Message.WParam, Message.LParam);
end;
procedure TFileDropper.Loaded;
var
Wnd: HWND;
begin
inherited Loaded;
if not (csDesigning in ComponentState) and (FDropSite <> nil) then
begin
Wnd := FDropSite.Handle;
FWndProcInstance := Classes.MakeObjectInstance(WndProc);
FDefProc := SetWindowLong(Wnd,GWL_WNDPROC,LongInt(FWndProcInstance));
DragAcceptFiles(Wnd, True);
end;
end;
procedure TFileDropper.DropFile(Drop: HDROP);
var
i, NumFiles: Integer;
lpszFileName: array [0..255] of Char;
begin
Finish := False;
NumFiles := DragQueryFile(Drop,0,nil,0);
for i := 0 to NumFiles - 1 do
begin
DragQueryFile(Drop,I,lpszFileName,SizeOf(lpszFileName));
Add(StrPas(lpszFileName));
Lista.Add(lpszFileName);
if i = NumFiles-2 then Finish := True;
end;
DragFinish(Drop);
end;
function TFileDropper.IsDirectory(Path: string): Boolean;
begin
Result := ((FileGetAttr(Path) and faDirectory) = 0);
end;
procedure TFileDropper.AddFolder(Path: string);
var
i: Integer;
SR: TSearchRec;
begin
i := FindFirst(Path + '\*.*', faAnyFile, SR);
while i = 0 do
begin
if ((SR.Name[1] <> '.') and (SR.Name[1] <> '..')) then
begin
if not IsDirectory(Path + '\' + SR.Name) then
begin
if not Lista.IndexOf(Path) > -1 then
if Assigned(FOnDrop) then FOnDrop(Self,Path + '\' + SR.Name);
end
else
if FSubFolder then
if not Lista.IndexOf(Path) > -1 then AddFolder(Path + '\' + SR.Name);
end;
i := FindNext(SR);
end;
FindClose(SR);
end;
procedure TFileDropper.Add(Path: string);
begin
if not IsDirectory(Path) then
begin
if not Lista.IndexOf(Path) > -1 then
if Assigned(FOnDrop) then FOnDrop(Self, Path);
end
else
if AllowDir then AddFolder(Path);
end;
procedure Register;
begin
RegisterComponents('Dropper', [TFileDropper]);
end;
end.