Drag&Drop plików w Windows 7/Vista

0

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.
0

No ładnie.... nawet ten kod nie działa na Windows 7 :/

Co to się porobiło.... jak to poprawić. NIKT NIE WIE ?

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Edit1: TEdit;
    Label1: TLabel;
    Label2: TLabel;
    procedure FormCreate(Sender: TObject);
  private
    procedure WMDropFiles(var Msg: TWMDropFiles); message WM_DROPFILES;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.WMDropFiles(var Msg: TWMDropFiles);
var
 NazwaPliku: array[0..MAX_PATH] of Char;
begin
 if DragQueryFile(Msg.Drop, 0, NazwaPliku, MAX_PATH)  > 0 then Edit1.Text := NazwaPliku;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
 DragAcceptFiles(Handle, True);
end;

end.
0

mi pod bcb dziala taki kodem

DragAcceptFiles(Handle, true);

MESSAGE void OnDropFiles(TMessage &Message);

MESSAGE void TFTex::OnDropFiles(TMessage &Message)
{
int texindex;
	 int nFiles;
	 char buffer[256];       AnsiString cmp;

	 nFiles = DragQueryFile((HDROP)Message.WParam, 0xFFFFFFFF, NULL, 0);
	 for (int i = 0; i < nFiles; i++)
	 {
		 DragQueryFile((HDROP)Message.WParam, i, buffer, 256);
		 // tutaj zrób co chcesz z upuszczonym plikiem, np. dodaj do ListBox1:

		 if (DirectoryExists((AnsiString)buffer ) == true) {
										   return;             ShowMessage("TO JEST KATALOG");
		 }

   if (TextureAllreadyInProject((AnsiString)buffer,cmp,texindex) == false) {
	TexList->Items->Add(	cmp );
	Add_texture_to_project((AnsiString)buffer);
   }           else
		ShowMessage("JUZ JEST");
		// ListBox1->Items->Add((AnsiString)buffer);
	 }

	 DragFinish((HDROP)Message.WParam);
}
0

Niestety to nic nie zmienia... poza tym to w C++.

W której wersji środowiska kompilujesz ? Może to jest od wersji ? np.: wersja 2010 jest kompatybilna z Windows 7...

0
procedure TForm1.WMDropFiles(var Msg: TWMDropFiles);
var
 NazwaPliku: array[0..MAX_PATH] of Char;
begin
 if DragQueryFile(Msg.Drop, 0, NazwaPliku, MAX_PATH)  > 0 then Edit1.Text := NazwaPliku;
end;

Nie wiem czy to w czymś pomoże, ale ostatni parametr przekazany do DragQueryFile powinien wynosić MAX_PATH + 1, albo SizeOf(NazwaPliku).

0

Niestety to też nie działa :/

procedure TForm1.WMDropFiles(var Msg: TWMDropFiles);
var
 NazwaPliku: array[0..SizeOf(NazwaPliku)] of Char;
begin
 DragQueryFile(Msg.Drop, 0, NazwaPliku, MAX_PATH);
 Edit1.Text := NazwaPliku;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
 DragAcceptFiles(Handle, True);
end;

1 użytkowników online, w tym zalogowanych: 0, gości: 1