模擬檔案總管複製檔案及目錄的範例

發表時間：2005-09-17 20:55:12
IP:61.62.xxx.xxx 未訂閱
在 http://delphi.ktop.com.tw/topic.php?TOPIC_ID=77557 的討論中我將 Anders Melander 的 Drag and Drop 元件下載下來研究 http://codecentral.borland.com/Item.aspx?id=14069 希望能解決問題, 可是我忽略了該篇是貼在 BCB 區, 再加上題目也不利於搜尋, 所以換個主題以便網友查詢.... 這個範例在 Button1 按下之後會將 'C:\icons' 這個目錄放到 Clipboard 內, 之後可以在檔案總管選一個目錄將其 "貼上"
unit Unit1;    interface    uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ActiveX, Clipbrd, ShlObj, StdCtrls;    type      TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;    var
  Form1: TForm1;
  CF_FILEGROUPDESCRIPTOR, CF_FILECONTENTS, CF_FILENAMEMAP, CF_FILENAMEMAPW,
  CF_IDLIST: UINT; //, CF_PREFERREDDROPEFFECT, CF_URL: UINT; //see initialization.
  ShellMalloc: IMalloc;    implementation    {$R *.dfm}    // -----------------------------------------------------------------------------
//                        Miscellaneous functions.
// -----------------------------------------------------------------------------    function GetSizeOfPidl(pidl: pItemIDList): integer;
var
  i: integer;
begin
  result := SizeOf(Word);
  repeat
    i := pSHItemID(pidl)^.cb;
    inc(result,i);
    inc(longint(pidl),i);
  until i = 0;
end;
// -----------------------------------------------------------------------------
function GetShellFolderOfPath(FolderPath: TFileName): IShellFolder;
var
  DeskTopFolder: IShellFolder;
  PathPidl: pItemIDList;
  OlePath: array[0..MAX_PATH] of WideChar;
  dummy,pdwAttributes: ULONG;
begin
  result := nil;
  StringToWideChar( FolderPath, OlePath, MAX_PATH );
  pdwAttributes := SFGAO_FOLDER;
  try
    if not (SHGetDesktopFolder(DeskTopFolder) = NOERROR) then exit;
    if (DesktopFolder.ParseDisplayName(0,
          nil,OlePath,dummy,PathPidl,pdwAttributes) = NOERROR) and
          (pdwAttributes and SFGAO_FOLDER <> 0) then
      DesktopFolder.BindToObject(PathPidl,nil,IID_IShellFolder,pointer(result));
    ShellMalloc.Free(PathPidl);
  except
  end;
end;
// -----------------------------------------------------------------------------
function GetFullPIDLFromPath(Path: TFileName): pItemIDList;
var
   DeskTopFolder: IShellFolder;
   OlePath: array[0..MAX_PATH] of WideChar;
   dummy1,dummy2: ULONG;
begin
  result := nil;
  StringToWideChar( Path, OlePath, MAX_PATH );
  try
    if (SHGetDesktopFolder(DeskTopFolder) = NOERROR) then
      DesktopFolder.ParseDisplayName(0,nil,OlePath,dummy1,result,dummy2);
  except
  end;
end;
// -----------------------------------------------------------------------------
function GetSubPidl(Folder: IShellFolder; Sub: TFilename): pItemIDList;
var
  dummy1,dummy2: ULONG;
  OleFile: array[0..MAX_PATH] of WideChar;
begin
  result := nil;
  try
    StringToWideChar( Sub, OleFile, MAX_PATH );
    Folder.ParseDisplayName(0,nil,OleFile,dummy1,result,dummy2);
  except
  end;
end;
// -----------------------------------------------------------------------------    //See "Clipboard Formats for Shell Data Transfers" in Ole.hlp...
//(Needed to drag links (shortcuts).)    type
  POffsets = ^TOffsets;
  TOffsets = array[0..$FFFF] of UINT;    function ConvertFilesToShellIDList(path: string; files: TStrings): HGlobal;
var
  shf: IShellFolder;
  PathPidl, pidl: pItemIDList;
  Ida: PIDA;
  pOffset: POffsets;
  ptrByte: ^Byte;
  i, PathPidlSize, IdaSize, PreviousPidlSize: integer;
begin
  result := 0;
  shf := GetShellFolderOfPath(path);
  if shf = nil then exit;
  //Calculate size of IDA structure ...
  // cidl: UINT ; Directory pidl offset: UINT ; all file pidl offsets
  IdaSize := (files.count   2) * sizeof(UINT);      PathPidl := GetFullPIDLFromPath(path);
  if PathPidl = nil then exit;
  PathPidlSize := GetSizeOfPidl(PathPidl);      //Add to IdaSize space for ALL pidls...
  IdaSize := IdaSize   PathPidlSize;
  for i := 0 to files.count-1 do
  begin
    pidl := GetSubPidl(shf,files[i]);
    IdaSize := IdaSize   GetSizeOfPidl(Pidl);
    ShellMalloc.Free(pidl);
  end;      //Allocate memory...
  Result := GlobalAlloc(GMEM_SHARE or GMEM_ZEROINIT, IdaSize);
  if (Result = 0) then
  begin
    ShellMalloc.Free(PathPidl);
    Exit;
  end;      Ida := GlobalLock(Result);
  try
    FillChar(Ida^,IdaSize,0);        //Fill in offset and pidl data...
    Ida^.cidl := files.count; //cidl = file count
    pOffset := @(Ida^.aoffset);
    pOffset^[0] := (files.count 2) * sizeof(UINT); //offset of Path pidl        ptrByte := pointer(Ida);
    inc(ptrByte,pOffset^[0]); //ptrByte now points to Path pidl
    move(PathPidl^, ptrByte^, PathPidlSize); //copy path pidl
    ShellMalloc.Free(PathPidl);        PreviousPidlSize := PathPidlSize;
    for i := 1 to files.count do
    begin
      pidl := GetSubPidl(shf,files[i-1]);
      pOffset^[i] := pOffset^[i-1]   UINT(PreviousPidlSize); //offset of pidl
      PreviousPidlSize := GetSizeOfPidl(Pidl);          ptrByte := pointer(Ida);
      inc(ptrByte,pOffset^[i]); //ptrByte now points to current file pidl
      move(Pidl^, ptrByte^, PreviousPidlSize); //copy file pidl
                            //PreviousPidlSize = current pidl size here
      ShellMalloc.Free(pidl);
    end;
  finally
    GlobalUnLock(Result);
  end;
end;    function DoGetData(const FormatEtcIn: TFormatEtc;
         out Medium: TStgMedium; fFiles,fMappedNames: TStringList):HRESULT;
var
  i: Integer;
  dropfiles: pDropFiles;
  pFile: PChar;
  pFileW: PWideChar;
  DropEffect: ^DWORD;
  strlength: Integer;
  tmpFilenames: TStringList;
begin
  Medium.tymed := 0;
  Medium.UnkForRelease := NIL;
  Medium.hGlobal := 0;      if fFiles.count = 0 then result := E_UNEXPECTED
  //--------------------------------------------------------------------------
  else if (FormatEtcIn.cfFormat = CF_HDROP) and
    (FormatEtcIn.dwAspect = DVASPECT_CONTENT) and
    (FormatEtcIn.tymed and TYMED_HGLOBAL <> 0) then
  begin
    strlength := 0;
    for i := 0 to fFiles.Count-1 do
      Inc(strlength, Length(fFiles[i]) 1);
    Medium.hGlobal :=
      GlobalAlloc(GMEM_SHARE or GMEM_ZEROINIT, SizeOf(TDropFiles) strlength 1);
    if (Medium.hGlobal = 0) then
      result:=E_OUTOFMEMORY
    else
    begin
      Medium.tymed := TYMED_HGLOBAL;
      dropfiles := GlobalLock(Medium.hGlobal);
      try
        dropfiles^.pfiles := SizeOf(TDropFiles);
        dropfiles^.fwide := False;
        longint(pFile) := longint(dropfiles) SizeOf(TDropFiles);
        for i := 0 to fFiles.Count-1 do
        begin
          StrPCopy(pFile,fFiles[i]);
          Inc(pFile, Length(fFiles[i]) 1);
        end;
        pFile^ := #0;
      finally
        GlobalUnlock(Medium.hGlobal);
      end;
      result := S_OK;
    end;
  end
  //--------------------------------------------------------------------------
  else if (FormatEtcIn.cfFormat = CF_FILENAMEMAP) and
    (FormatEtcIn.dwAspect = DVASPECT_CONTENT) and
    (FormatEtcIn.tymed and TYMED_HGLOBAL <> 0) and
    //make sure there is a Mapped Name for each filename...
    (fMappedNames.Count = fFiles.Count) then
  begin
    strlength := 0;
    for i := 0 to fMappedNames.Count-1 do
      Inc(strlength, Length(fMappedNames[i]) 1);        Medium.hGlobal :=
      GlobalAlloc(GMEM_SHARE or GMEM_ZEROINIT, strlength 1);
    if (Medium.hGlobal = 0) then
      result:=E_OUTOFMEMORY
    else
    begin
      Medium.tymed := TYMED_HGLOBAL;
      pFile := GlobalLock(Medium.hGlobal);
      try
        for i := 0 to fMappedNames.Count-1 do
        begin
          StrPCopy(pFile,fMappedNames[i]);
          Inc(pFile, Length(fMappedNames[i]) 1);
        end;
        pFile^ := #0;
      finally
        GlobalUnlock(Medium.hGlobal);
      end;
      result := S_OK;
    end;
  end
  //--------------------------------------------------------------------------
  else if (FormatEtcIn.cfFormat = CF_FILENAMEMAPW) and
    (FormatEtcIn.dwAspect = DVASPECT_CONTENT) and
    (FormatEtcIn.tymed and TYMED_HGLOBAL <> 0) and
    //make sure there is a Mapped Name for each filename...
    (fMappedNames.Count = fFiles.Count) then
  begin
    strlength := 2;
    for i := 0 to fMappedNames.Count-1 do
      Inc(strlength, (Length(fMappedNames[i]) 1)*2);        Medium.hGlobal := GlobalAlloc(GMEM_SHARE or GMEM_ZEROINIT, strlength);
    if (Medium.hGlobal = 0) then
      result:=E_OUTOFMEMORY
    else
    begin
      Medium.tymed := TYMED_HGLOBAL;
      pFileW := GlobalLock(Medium.hGlobal);
      try
        for i := 0 to fMappedNames.Count-1 do
        begin
          StringToWideChar(fMappedNames[i], pFileW,
            (length(fMappedNames[i]) 1)*2);
          Inc(pFileW, Length(fMappedNames[i]) 1);
        end;
        pFileW^ := #0;
      finally
        GlobalUnlock(Medium.hGlobal);
      end;
      result := S_OK;
    end;
  end
  //--------------------------------------------------------------------------
  else if (FormatEtcIn.cfFormat = CF_IDLIST) and
    (FormatEtcIn.dwAspect = DVASPECT_CONTENT) and
    (FormatEtcIn.tymed and TYMED_HGLOBAL <> 0) then
  begin
    tmpFilenames := TStringList.create;
    try
      Medium.tymed := TYMED_HGLOBAL;
      for i := 0 to fFiles.count-1 do
        tmpFilenames.add(extractfilename(fFiles[i]));
      Medium.hGlobal :=
          ConvertFilesToShellIDList(extractfilepath(fFiles[0]),tmpFilenames);
      if Medium.hGlobal = 0 then
        result:=E_outOFMEMORY else
        result := S_OK;
    finally
      tmpFilenames.free;
    end;
  end
  //--------------------------------------------------------------------------      ////This next format does not work for Win95 but should for Win98, WinNT ...
  ////It stops the shell from prompting (with a popup menu) for the choice of
  ////Copy/Move/Shortcut when performing a file 'Shortcut' onto Desktop or Explorer.
  //else if (FormatEtcIn.cfFormat = CF_PREFERREDDROPEFFECT) and
  //  (FormatEtcIn.dwAspect = DVASPECT_CONTENT) and
  //  (FormatEtcIn.tymed and TYMED_HGLOBAL <> 0) then
  //begin
  //  Medium.tymed := TYMED_HGLOBAL;
  //  Medium.hGlobal := GlobalAlloc(GMEM_SHARE or GMEM_ZEROINIT, SizeOf(DWORD));
  //  if Medium.hGlobal = 0 then
  //    result:=E_outOFMEMORY
  //  else
  //  begin
  //    DropEffect := GlobalLock(Medium.hGlobal);
  //    try
  //      DropEffect^ := DWORD(FeedbackEffect);
  //    finally
  //      GlobalUnLock(Medium.hGlobal);
  //    end;
  //    result := S_OK;
  //  end;
  //end
  else
    result := DV_E_FORMATETC;
end;    function CutOrCopyToClipboard_Files: boolean;
var
  FormatEtcIn: TFormatEtc;
  Medium: TStgMedium;
  fFiles,fMappedNames: TStringList;
begin
  fFiles := TStringList.Create;
  fMappedNames := TStringList.Create;      try
    fFiles.Add('C:\icons');
    FormatEtcIn.cfFormat := CF_HDROP;
    FormatEtcIn.dwAspect := DVASPECT_CONTENT;
    FormatEtcIn.tymed := TYMED_HGLOBAL;
    if (fFiles.count = 0) then result := false
    else if DoGetData(formatetcIn,Medium,fFiles,fMappedNames) = S_OK then
    begin
      Clipboard.SetAsHandle(CF_HDROP,Medium.hGlobal);
      result := true;
    end else result := false;
  finally
    fFiles.Free;
    fMappedNames.Free;
  end;
end;    function CutOrCopyToClipboard_Link: boolean;
var
  FormatEtcIn: TFormatEtc;
  Medium: TStgMedium;
  fFiles,fMappedNames: TStringList;
begin
  fFiles := TStringList.Create;
  fMappedNames := TStringList.Create;      try
    fFiles.Add('C:\icons');
    FormatEtcIn.cfFormat := CF_IDLIST;
    FormatEtcIn.dwAspect := DVASPECT_CONTENT;
    FormatEtcIn.tymed := TYMED_HGLOBAL;
    if (fFiles.count = 0) then result := false
    else if DoGetData(formatetcIn,Medium,fFiles,fMappedNames) = S_OK then
    begin
      Clipboard.SetAsHandle(CF_IDLIST,Medium.hGlobal);
      result := true;
    end else result := false;
  finally
    fFiles.Free;
    fMappedNames.Free;
  end;
end;    procedure TForm1.Button1Click(Sender: TObject);
begin
  CutOrCopyToClipboard_Files;
  //CutOrCopyToClipboard_Link;
end;    initialization
  OleInitialize(NIL);      CF_FILECONTENTS := RegisterClipboardFormat(CFSTR_FILECONTENTS);
  CF_FILEGROUPDESCRIPTOR := RegisterClipboardFormat(CFSTR_FILEDESCRIPTOR);
  CF_IDLIST := RegisterClipboardFormat(CFSTR_SHELLIDLIST);
  //CF_PREFERREDDROPEFFECT := RegisterClipboardFormat('Preferred DropEffect');
  //CF_URL := RegisterClipboardFormat('UniformResourceLocator');
  CF_FILENAMEMAP := RegisterClipboardFormat(CFSTR_FILENAMEMAPA);
  CF_FILENAMEMAPW := RegisterClipboardFormat(CFSTR_FILENAMEMAPW);      ShGetMalloc(ShellMalloc);
finalization
  OleUninitialize;
end.
發表人 - malanlk 於 2005/09/17 21:02:16