    unit UnitFileCatch;

interface

uses WinAPI.Windows, System.Classes, WinAPI.ActiveX;


type
  TDropCallback = interface
    function DropAllowed(const FileNames: array of string): Boolean; overload;
    function DropAllowed(dataObj : IDataObject) : boolean; overload;
    procedure Drop(const FileNames: array of string); overload;
    procedure Drop(dataObj : IDataObject); overload;
  end;



procedure AddDropListener(handle : THandle; callback : TDropCallback);


implementation

uses Winapi.ShellAPI, System.StrUtils, Vcl.Forms, UnitMisc;


type
  TDropTarget = class(TInterfacedObject, IDropTarget)
  private
    FHandle: HWND;
    fCallback : TDropCallback;
    FDropAllowed: Boolean;
    function ExtractFileNames(const dataObj: IDataObject; var FileNames: TArray<string>) : boolean;
    procedure SetEffect(var dwEffect: Integer);
  public
    function DragEnter(const dataObj: IDataObject; grfKeyState: Integer; pt: TPoint; var dwEffect: Integer): 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;

    constructor Create(AHandle: HWND; const ADragDrop: TDropCallback);
    destructor Destroy; override;
  end;



procedure AddDropListener(handle : THandle; callback : TDropCallback);
begin
    TDropTarget.Create(handle, callback);
end;


{ TDropTarget }

constructor TDropTarget.Create(AHandle: HWND; const ADragDrop: TDropCallback);
begin
    inherited Create;
    FHandle := AHandle;
    fCallback := ADragDrop;
    RegisterDragDrop(FHandle, Self)
end;
destructor TDropTarget.Destroy;
begin
    RevokeDragDrop(FHandle);
    inherited;
end;

function TDropTarget.ExtractFileNames(const dataObj: IDataObject; var FileNames: TArray<string>) : boolean;
var
    i, len : Integer;
    formatetcIn: TFormatEtc;
    medium: TStgMedium;
    dropHandle: THandle;
begin
    result := false;
    FileNames := nil;
    with formatetcIn do begin
        cfFormat := CF_HDROP;
        ptd := nil;
        dwAspect := DVASPECT_CONTENT;
        lindex := -1;
        tymed := TYMED_HGLOBAL;
    end;
    if dataObj.GetData(formatetcIn, medium) = S_OK then begin
        dropHandle := THandle(medium.hGlobal);
        len :=  DragQueryFile(dropHandle, $FFFFFFFF, nil, 0);
        if len = 0 then EXIT;
        SetLength(FileNames, len);
        for i := low(filenames) to high(FileNames) do begin
            len := DragQueryFile(dropHandle, i, nil, 0) + 1;
            SetLength(FileNames[i], len);
            DragQueryFile(dropHandle, i, @FileNames[i][1], len);
            FileNames[i] := PChar(FileNames[i]);
            result := true;
        end;
    end;
end;
procedure TDropTarget.SetEffect(var dwEffect: Integer);
begin
    dwEffect := DROPEFFECT_NONE;
    if FDropAllowed then begin
        dwEffect := DROPEFFECT_COPY;
    end;
end;

function TDropTarget.DragEnter(const dataObj: IDataObject; grfKeyState: Integer; pt: TPoint; var dwEffect: Integer): HResult;
var
    FileNames : TArray<string>;
begin
    result := S_OK;

    fDropAllowed := ExtractFileNames(dataObj, FileNames);
    if FDropAllowed then begin
        FDropAllowed := fCallback.DropAllowed(FileNames);
    end else begin
        FDropAllowed := fCallback.DropAllowed(dataObj);
    end;
    SetEffect(dwEffect);
end;
function TDropTarget.DragOver(grfKeyState: Integer; pt: TPoint; var dwEffect: Integer): HResult;
begin
    SetEffect(dwEffect);
    result := S_OK;
end;
function TDropTarget.DragLeave: HResult;
begin
    result := S_OK;
    FDropAllowed := false;
end;
function TDropTarget.Drop(const dataObj: IDataObject; grfKeyState: Integer; pt: TPoint; var dwEffect: Integer): HResult;
var
    FileNames: TArray<string>;
begin
    Result := S_OK;
    dwEffect := DROPEFFECT_NONE;
    if ExtractFileNames(dataObj, FileNames) then begin
        fCallback.Drop(FileNames);
        dwEffect := DROPEFFECT_COPY;
    end else begin
        fCallback.Drop(dataObj);
        dwEffect := DROPEFFECT_COPY;
    end;
end;


initialization
OleInitialize(nil);

finalization
OleUninitialize;
end.
