uses
  ActiveX, ShlObj, ComObj, ShlwApi;

const
  shlwapi32 = 'shlwapi.dll';

function SHCreateStreamOnFileEx(pszFile: LPCWSTR; grfMode: DWORD; dwAttributes: DWORD; fCreate: BOOL;
  pstmTemplate: Pointer; out ppstm: IStream): HRESULT; stdcall; external shlwapi32 name 'SHCreateStreamOnFileEx';

var
  CF_FILECONTENTS: UINT;
  CF_FILEDESCRIPTORA: UINT;
  CF_FILEDESCRIPTORW: UINT;

function ContainFormat(ADataObject: IDataObject; AFormat: TClipFormat; ATymed: Longint;
  AAspect: LongInt = DVASPECT_CONTENT; AIndex: LongInt = -1): Boolean;
var
  Format: TFormatEtc;
begin
  ZeroMemory(@Format, SizeOf(Format));
  Format.cfFormat := AFormat;
  Format.dwAspect := AAspect;
  Format.lindex := AIndex;
  Format.tymed := ATymed;
  Result := ADataObject.QueryGetData(Format) = S_OK;
end;

procedure RaiseInvalidMedium;
begin
  raise EOleSysError.Create('Invalid medium', E_INVALIDARG, 0);
end;

function GetFileContent(ADataObject: IDataObject; AIndex: Integer): IStream;
var
  Format: TFormatEtc;
  Medium: TStgMedium;
begin
  ZeroMemory(@Format, SizeOf(Format));
  Format.cfFormat := CF_FILECONTENTS;
  Format.dwAspect := DVASPECT_CONTENT;
  Format.lindex := AIndex;
  Format.tymed := TYMED_ISTREAM;
  ZeroMemory(@Medium, SizeOf(Medium));
  OleCheck(ADataObject.GetData(Format, Medium));
  try
    if (Medium.tymed and TYMED_ISTREAM = 0) or (Medium.stm = nil) then
      RaiseInvalidMedium;
    Result := IStream(Medium.stm);
  finally
    ReleaseStgMedium(Medium);
  end
end;

procedure SaveFileDescriptorWToDir(ADataObject: IDataObject; const ADir: string);
var
  Format: TFormatEtc;
  Medium: TStgMedium;
  GroupDescriptor: PFileGroupDescriptorW;
  FileDescriptorW: PFileDescriptorW;
  ItemIndex: Integer;
  DestFileName: UnicodeString;
  DestStream: IStream;
  SourceStream: IStream;
  Read: Int64;
  Written: Int64;
begin
  ZeroMemory(@Format, SizeOf(Format));
  Format.cfFormat := CF_FILEDESCRIPTORW;
  Format.dwAspect := DVASPECT_CONTENT;
  Format.lindex := -1;
  Format.tymed := TYMED_HGLOBAL;
  ZeroMemory(@Medium, SizeOf(Medium));
  OleCheck(ADataObject.GetData(Format, Medium));
  try
    if (Medium.tymed and TYMED_HGLOBAL = 0) or (Medium.hGlobal = 0) then
      RaiseInvalidMedium;
    GroupDescriptor := GlobalLock(Medium.hGlobal);
    if not Assigned(GroupDescriptor) then
      RaiseLastOSError;
    try
      if GroupDescriptor.cItems = 0 then Exit;
      for ItemIndex := 0 to GroupDescriptor.cItems - 1 do
        begin
          FileDescriptorW := @GroupDescriptor.fgd[ItemIndex];

          // По правильному нужно проверить корректность имени на отсутствие недопустимых символов
          DestFileName := FileDescriptorW.cFileName;

          DestFileName := IncludeTrailingPathDelimiter(ADir) + DestFileName;

          if (FileDescriptorW.dwFlags and FD_ATTRIBUTES <> 0) and (FileDescriptorW.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY <> 0) then
            begin
              ForceDirectories(DestFileName);
              // По правильному нужно установить даты и аттрибуты директории на основе FileDescriptorW
            end
          else
            begin
              ForceDirectories(ExtractFilePath(DestFileName));
              OleCheck(SHCreateStreamOnFileEx(PWideChar(DestFileName), STGM_CREATE or STGM_READWRITE, FILE_ATTRIBUTE_NORMAL, True, nil, DestStream));
              try
                SourceStream := GetFileContent(ADataObject, ItemIndex);
                try
                  OleCheck(SourceStream.CopyTo(DestStream, -1, Read, Written));
                  // По правильному нужно установить даты и аттрибуты файла на основе FileDescriptorW
                finally
                  SourceStream := nil;
                end;
              finally
                DestStream := nil;
              end;
            end;
        end;
    finally
      GlobalUnlock(Medium.hGlobal);
    end;
  finally
    ReleaseStgMedium(Medium);
  end
end;

procedure SaveClipboardToDir(const ADir: string);
var
  DataObject: IDataObject;
begin
  OleCheck(OleGetClipboard(DataObject));
  try
    if ContainFormat(DataObject, CF_FILEDESCRIPTORW, TYMED_HGLOBAL) then
      SaveFileDescriptorWToDir(DataObject, ADir)
    else

    {if ContainFormat(DataObject, CF_FILEDESCRIPTORA, TYMED_HGLOBAL) then
      SaveFileDescriptorAToDir(DataObject, ADir)
    else}

      raise Exception.Create('Data not found');
  finally
    DataObject := nil;
  end;
end;

initialization
  CF_FILECONTENTS               := RegisterClipboardFormat(CFSTR_FILECONTENTS);
  CF_FILEDESCRIPTORA            := RegisterClipboardFormat(CFSTR_FILEDESCRIPTORA);
  CF_FILEDESCRIPTORW            := RegisterClipboardFormat(CFSTR_FILEDESCRIPTORW);

end.

uses
  ActiveX, ShlObj, ComObj, ShlwApi;

const
  shlwapi32 = 'shlwapi.dll';
  ole32     = 'ole32.dll';

function SHCreateStreamOnFileEx(pszFile: LPCWSTR; grfMode: DWORD; dwAttributes: DWORD; fCreate: BOOL;
  pstmTemplate: Pointer; out ppstm: IStream): HRESULT; stdcall; external shlwapi32 name 'SHCreateStreamOnFileEx';

type
  STGFMT = type Integer;

const
  STGFMT_STORAGE  = 0;
  STGFMT_FILE     = 3;
  STGFMT_ANY      = 4;
  STGFMT_DOCFILE  = 5;

function StgCreateStorageEx(pwcsName: PWideChar; grfMode: DWORD; stgfmt: STGFMT; grfAttrs: DWORD;
  pStgOptions: Pointer {STGOPTIONS}; pSecurityDescriptor: PSecurityDescriptor; const riid: TIID; out ppObjectOpen): HRESULT; stdcall; external ole32 name 'StgCreateStorageEx';

var
  CF_FILECONTENTS: UINT;
  CF_FILEDESCRIPTORA: UINT;
  CF_FILEDESCRIPTORW: UINT;

function ContainFormat(ADataObject: IDataObject; AFormat: TClipFormat; ATymed: Longint;
  AAspect: LongInt = DVASPECT_CONTENT; AIndex: LongInt = -1): Boolean;
var
  Format: TFormatEtc;
begin
  ZeroMemory(@Format, SizeOf(Format));
  Format.cfFormat := AFormat;
  Format.dwAspect := AAspect;
  Format.lindex := AIndex;
  Format.tymed := ATymed;
  Result := ADataObject.QueryGetData(Format) = S_OK;
end;

procedure RaiseInvalidMedium;
begin
  raise EOleSysError.Create('Invalid medium', E_INVALIDARG, 0);
end;

function GetFileContentAsStream(ADataObject: IDataObject; AIndex: Integer; out AStream: IStream): Boolean;
var
  Format: TFormatEtc;
  Medium: TStgMedium;
begin
  Result := False;
  ZeroMemory(@Format, SizeOf(Format));
  Format.cfFormat := CF_FILECONTENTS;
  Format.dwAspect := DVASPECT_CONTENT;
  Format.lindex := AIndex;
  Format.tymed := TYMED_ISTREAM;
  ZeroMemory(@Medium, SizeOf(Medium));
  if Succeeded(ADataObject.GetData(Format, Medium)) then
    try
      if (Medium.tymed and TYMED_ISTREAM = 0) or (Medium.stm = nil) then
        RaiseInvalidMedium;

      AStream := IStream(Medium.stm);
      Result := True;
    finally
      ReleaseStgMedium(Medium);
    end
end;

function GetFileContentAsStorage(ADataObject: IDataObject; AIndex: Integer; out AStream: IStorage): Boolean;
var
  Format: TFormatEtc;
  Medium: TStgMedium;
begin
  Result := False;
  ZeroMemory(@Format, SizeOf(Format));
  Format.cfFormat := CF_FILECONTENTS;
  Format.dwAspect := DVASPECT_CONTENT;
  Format.lindex := AIndex;
  Format.tymed := TYMED_ISTORAGE;
  ZeroMemory(@Medium, SizeOf(Medium));
  if Succeeded(ADataObject.GetData(Format, Medium)) then
    try
      if (Medium.tymed and TYMED_ISTORAGE = 0) or (Medium.stm = nil) then
        RaiseInvalidMedium;

      AStream := IStorage(Medium.stg);
      Result := True;
    finally
      ReleaseStgMedium(Medium);
    end
end;

procedure SaveFileDescriptorWToDir(ADataObject: IDataObject; const ADir: string);
var
  Format: TFormatEtc;
  Medium: TStgMedium;
  GroupDescriptor: PFileGroupDescriptorW;
  FileDescriptorW: PFileDescriptorW;
  ItemIndex: Integer;
  DestFileName: UnicodeString;
  DestStream: IStream;
  SourceStream: IStream;
  Read: Int64;
  Written: Int64;
  DestStorage: IStorage;
  SourceStorage: IStorage;
begin
  ZeroMemory(@Format, SizeOf(Format));
  Format.cfFormat := CF_FILEDESCRIPTORW;
  Format.dwAspect := DVASPECT_CONTENT;
  Format.lindex := -1;
  Format.tymed := TYMED_HGLOBAL;
  ZeroMemory(@Medium, SizeOf(Medium));
  OleCheck(ADataObject.GetData(Format, Medium));
  try
    if (Medium.tymed and TYMED_HGLOBAL = 0) or (Medium.hGlobal = 0) then
      RaiseInvalidMedium;
    GroupDescriptor := GlobalLock(Medium.hGlobal);
    if not Assigned(GroupDescriptor) then
      RaiseLastOSError;
    try
      if GroupDescriptor.cItems = 0 then Exit;
      for ItemIndex := 0 to GroupDescriptor.cItems - 1 do
        begin
          FileDescriptorW := @GroupDescriptor.fgd[ItemIndex];

          // По правильному нужно проверить корректность имени на отсутствие недопустимых символов
          DestFileName := FileDescriptorW.cFileName;

          DestFileName := IncludeTrailingPathDelimiter(ADir) + DestFileName;

          if (FileDescriptorW.dwFlags and FD_ATTRIBUTES <> 0) and (FileDescriptorW.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY <> 0) then
            begin
              ForceDirectories(DestFileName);
              // По правильному нужно установить даты и аттрибуты директории на основе FileDescriptorW
            end
          else
            begin
              ForceDirectories(ExtractFilePath(DestFileName));

              if GetFileContentAsStream(ADataObject, ItemIndex, SourceStream) then
                try
                  OleCheck(SHCreateStreamOnFileEx(PWideChar(DestFileName), STGM_CREATE or STGM_READWRITE, FILE_ATTRIBUTE_NORMAL, True, nil, DestStream));
                  try
                    OleCheck(SourceStream.CopyTo(DestStream, -1, Read, Written));
                    // По правильному нужно установить даты и аттрибуты файла на основе FileDescriptorW
                  finally
                    DestStream := nil;
                  end;
                finally
                  SourceStream := nil;
                end
              else
                if GetFileContentAsStorage(ADataObject, ItemIndex, SourceStorage) then
                  try
                    OleCheck(StgCreateStorageEx(PWideChar(DestFileName), STGM_CREATE or STGM_SHARE_EXCLUSIVE or STGM_READWRITE, STGFMT_STORAGE, 0, nil, nil, IStorage, DestStorage));
                    try
                      OleCheck(SourceStorage.CopyTo(0, nil, 0, DestStorage));
                    finally
                      DestStorage := nil;
                    end;
                  finally
                    SourceStorage := nil;
                  end;
            end;
        end;
    finally
      GlobalUnlock(Medium.hGlobal);
    end;
  finally
    ReleaseStgMedium(Medium);
  end
end;

procedure SaveClipboardToDir(const ADir: string);
var
  DataObject: IDataObject;
  OleInitializeSuccess: Boolean;
begin
  OleInitializeSuccess := OleInitialize(nil) = S_OK;
  try
    OleCheck(OleGetClipboard(DataObject));
    try
      if ContainFormat(DataObject, CF_FILEDESCRIPTORW, TYMED_HGLOBAL) then
        SaveFileDescriptorWToDir(DataObject, ADir)
      else
        raise Exception.Create('Data not found');
    finally
      DataObject := nil;
    end;
  finally
    if OleInitializeSuccess then
      OleUninitialize;
  end;
end;

initialization
  CF_FILECONTENTS               := RegisterClipboardFormat(CFSTR_FILECONTENTS);
  CF_FILEDESCRIPTORA            := RegisterClipboardFormat(CFSTR_FILEDESCRIPTORA);
  CF_FILEDESCRIPTORW            := RegisterClipboardFormat(CFSTR_FILEDESCRIPTORW);