Autor: R.Kleinpeter
{This example will show you how your application
will be able to copy files from your application to
Windows Explorer using Drag'n Drop.
Exactly the way it is done by the OS itself!
Create a new application containing just one unit,
called 'Unit1'. Drop a FileListBox and a DirectoryListBox on to the form,
leave their names the way they are.
Connect FileListBox1 with DirectoryListBox1 by setting the FileList-property of
DirectoryListBox1. Make sure that the MultiSelect-property of FileListBox1 is set to 'True'!
The best thing you can do now is to replace all text with the code below:}
//---------------------------------------------
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs,
StdCtrls, FileCtrl,
ActiveX, ShlObj, ComObj;
type
TForm1 =
class(TForm, IDropSource)
FileListBox1: TFileListBox;
DirectoryListBox1: TDirectoryListBox;
procedure FileListBox1MouseDown(Sender: TObject; Button:
TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure FileListBox1MouseMove(Sender: TObject; Shift: TShiftState;
X,
Y: Integer);
private
FDragStartPos: TPoint;
function QueryContinueDrag(fEscapePressed: BOOL;
grfKeyState: Longint): HResult;
stdcall;
function GiveFeedback(dwEffect: Longint): HResult;
stdcall;
public
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
function GetFileListDataObject(
const Directory:
string; Files:
TStrings):
IDataObject;
type
PArrayOfPItemIDList = ^TArrayOfPItemIDList;
TArrayOfPItemIDList =
array[0..0]
of PItemIDList;
var
Malloc: IMalloc;
Root: IShellFolder;
FolderPidl: PItemIDList;
Folder: IShellFolder;
p: PArrayOfPItemIDList;
chEaten: ULONG;
dwAttributes: ULONG;
FileCount: Integer;
i: Integer;
begin
Result :=
nil;
if Files.Count = 0
then
Exit;
OleCheck(SHGetMalloc(Malloc));
OleCheck(SHGetDesktopFolder(Root));
OleCheck(Root.ParseDisplayName(0,
nil,
PWideChar(WideString(Directory)),
chEaten, FolderPidl, dwAttributes));
try
OleCheck(Root.BindToObject(FolderPidl,
nil, IShellFolder,
Pointer(Folder)));
FileCount := Files.Count;
p := AllocMem(SizeOf(PItemIDList) * FileCount);
try
for i := 0
to FileCount - 1
do
begin
OleCheck(Folder.ParseDisplayName(0,
nil,
PWideChar(WideString(Files[i])), chEaten, p^[i],
dwAttributes));
end;
OleCheck(Folder.GetUIObjectOf(0, FileCount, p^[0], IDataObject,
nil,
Pointer(Result)));
finally
for i := 0
to FileCount - 1
do begin
if p^[i] <>
nil then Malloc.Free(p^[i]);
end;
FreeMem(p);
end;
finally
Malloc.Free(FolderPidl);
end;
end;
function TForm1.QueryContinueDrag(fEscapePressed: BOOL;
grfKeyState: Longint): HResult;
stdcall;
begin
if fEscapePressed
or (grfKeyState
and MK_RBUTTON = MK_RBUTTON)
then
begin
Result := DRAGDROP_S_CANCEL
end else if grfKeyState
and MK_LBUTTON = 0
then
begin
Result := DRAGDROP_S_DROP
end else
begin
Result := S_OK;
end;
end;
function TForm1.GiveFeedback(dwEffect: Longint): HResult;
stdcall;
begin
Result := DRAGDROP_S_USEDEFAULTCURSORS;
end;
procedure TForm1.FileListBox1MouseDown(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
if Button = mbLeft
then
begin
FDragStartPos.x := X;
FDragStartPos.y := Y;
end;
end;
procedure TForm1.FileListBox1MouseMove(Sender: TObject; Shift:
TShiftState;
X, Y: Integer);
const
Threshold = 5;
var
SelFileList: TStrings;
i: Integer;
DataObject: IDataObject;
Effect: DWORD;
begin
with Sender
as TFileListBox
do
begin
if (SelCount > 0)
and (csLButtonDown
in ControlState)
and ((Abs(X - FDragStartPos.x) >= Threshold)
or (Abs(Y - FDragStartPos.y) >= Threshold))
then
begin
Perform(WM_LBUTTONUP, 0, MakeLong(X, Y));
SelFileList := TStringList.Create;
try
SelFileList.Capacity := SelCount;
for i := 0
to Items.Count - 1
do
if Selected[i]
then SelFileList.Add(Items[i]);
DataObject := GetFileListDataObject(Directory, SelFileList);
finally
SelFileList.Free;
end;
Effect := DROPEFFECT_NONE;
DoDragDrop(DataObject, Self, DROPEFFECT_COPY, Effect);
//<- [DCC Fehler] Virtual_Listbox_Unit.pas(589): E2033 Die Typen der tatsächlichen und formalen Var-Parameter müssen übereinstimmen
end;
end;
end;
initialization
OleInitialize(
nil);
finalization
OleUninitialize;
end.