"А я все чаще замечаю, что..." в тестовых проектиках для выбора файла нажимать на какую-нибудь кнопку "Browse" и выбирать файл - слишком долго.. Намного быстрее получается перетащить нужный файл (особенно когда надо перепробовать десятки файлов) из окна проводника в свой тестовый проект
Вдруг кому-то пригодится - модуль, облегчающий это действие -несколько шагов, чтобы все заработало:
- добавить .pas файл в проект или путь к файлу в настройки окружения - кому как нравится
- добавить в uses формы, которая будет принимать дропы, ссылку на модуль
- создать 2 обработчика, для реакции на "мышка с обьектом над нами" и "юзер бросил нам обьект"
- ну и создать собственно экземпляр класса в подходящем месте
Где-то вот так:
...
type
TfrmMain = class(TForm)
...
private
...
procedure FileDropEvent (Sender: TObject; const Filenames: TWideStrings);
procedure FileEnterEvent (Sender: TObject; const Filenames: TWideStrings; var Accept: boolean);
public
{ Public declarations }
end;
var
frmMain: TfrmMain;
implementation
uses
DragDropSupportUnit, ActiveX;
var
FileDrop: TFileDrop;
{$R *.dfm}
...
procedure TfrmMain.FileEnterEvent(Sender: TObject; const Filenames: TWideStrings; var Accept: boolean);
begin
// разрешим дропать только файлы по какому-то правилу - скажем только файлы .mp3
Accept := AnsiLowerCase ( ExtractFileExt ( Filenames [0] ) ) = '.flv';
end;
procedure TfrmMain.FileDropEvent(Sender: TObject; const Filenames: TWideStrings);
begin
// прореагируем на бросание файлов на контрол (файлов может быть и несколько)
if Filenames.Count > 1 then
begin
MessageBox(Handle, 'Many files - will be used only first', 'Warning', MB_OK + MB_ICONINFORMATION);
end;
edSource.Text := Filenames [0];
end;
...
procedure TfrmMain.FormCreate(Sender: TObject);
begin
...
FileDrop := TFileDrop.Create ( FileDropEvent, FileEnterEvent );
RegisterDragDrop (Handle, FileDrop as IDropTarget);
...
end;
procedure TfrmMain.FormDestroy(Sender: TObject);
begin
...
RevokeDragDrop(handle);
...
end;
Это все: вызов RegisterDragDrop назначает контрол, handle которого передали параметром, приемником драг-дропа (так что это может быть как вся форма, так и к примеру только поле ввода.. дропаем файл на поле ввода и там тут же появляется имя файла), закрывая программу вертаем все взад.
Код собственно полезного модуля (мне лениво в пятницу вечером делать архив, ложить куда-то на рапиду.. скопипастить в ide да сохранить):
// использование: создать обьект, передав ему указатели на обработчики
// OnEnter и OnDrop и зарегистрировать приемник drag-drop-а:
// RegisterDragDrop (Handle, FFileDrop as IDropTarget);
unit DragDropSupportUnit;
interface
uses
windows, sysutils, widestrings, ActiveX, shellAPI;
type
TFileDropEvent = procedure (Sender: TObject; const Filenames: TWideStrings) of object;
TFileEnterEvent = procedure (Sender: TObject; const Filenames: TWideStrings; var Accept: boolean) of object;
TFileDrop = class (TInterfacedObject, IDropTarget)
private
FDropEvent: TFileDropEvent;
FEnterEvent: TFileEnterEvent;
FFilenames: TWideStrings;
FCanDrop: boolean;
public
constructor Create (AOnDrop: TFileDropEvent; AOnEnter: TFileEnterEvent);
destructor Destroy; override;
function DragEnter(const dataObj: IDataObject; grfKeyState: Longint;
pt: TPoint; var dwEffect: Longint): HResult; stdcall;
function DragOver(grfKeyState: Longint; pt: TPoint;
var dwEffect: Longint): HResult; stdcall;
function DragLeave: HResult; stdcall;
function Drop(const dataObj: IDataObject; grfKeyState: Longint; pt: TPoint;
var dwEffect: Longint): HResult; stdcall;
end;
implementation
{ TFileDrop }
constructor TFileDrop.Create(AOnDrop: TFileDropEvent;
AOnEnter: TFileEnterEvent);
begin
inherited Create;
FDropEvent := AOnDrop;
FEnterEvent := AOnEnter;
FCanDrop := false;
FFilenames := TWideStringList.Create;
end;
destructor TFileDrop.Destroy;
begin
FFilenames.Free;
inherited;
end;
function TFileDrop.DragEnter(const dataObj: IDataObject;
grfKeyState: Integer; pt: TPoint; var dwEffect: Integer): HResult;
var
medium: TStgMedium;
format: TFormatEtc;
fn: array [0..MAX_PATH] of char;
fcount, i: integer;
begin
dataObj._AddRef;
format.cfFormat := CF_HDROP;
format.ptd := nil;
format.dwAspect := DVASPECT_CONTENT;
format.lindex := -1;
format.tymed := TYMED_HGLOBAL;
if dataObj.GetData (format, medium) = S_OK then
begin
fcount := DragQueryFile (medium.hGlobal, $FFFFFFFF, nil, 0);
if fcount > 0 then
begin
for i := 0 to fcount - 1 do
begin
DragQueryFile (medium.hGlobal, i, fn, sizeof (fn));
FFilenames.Add ( string ( fn ) );
end;
FCanDrop := true;
end else
FFilenames.Clear;
end;
if medium.unkForRelease = nil then
ReleaseStgMedium (medium);
dataObj._Release;
if Assigned (FEnterEvent) then
FEnterEvent (self, FFilenames, FCanDrop);
if FCanDrop then
dwEffect := DROPEFFECT_COPY
else
dwEffect := DROPEFFECT_NONE;
Result := S_OK;
end;
function TFileDrop.DragLeave: HResult;
begin
FFilenames.Clear;
Result := S_OK;
end;
function TFileDrop.DragOver(grfKeyState: Integer; pt: TPoint;
var dwEffect: Integer): HResult;
begin
if FCanDrop then
dwEffect := DROPEFFECT_COPY
else
dwEffect := DROPEFFECT_NONE;
Result := S_OK;
end;
function TFileDrop.Drop(const dataObj: IDataObject; grfKeyState: Integer;
pt: TPoint; var dwEffect: Integer): HResult;
begin
if Assigned (FDropEvent) and FCanDrop then
begin
FDropEvent (self, FFilenames);
dwEffect := DROPEFFECT_COPY;
end else
dwEffect := DROPEFFECT_NONE;
FFilenames.Clear;
Result := S_OK;
end;
initialization
OleInitialize(nil);
finalization
OleUninitialize;
end.
