模擬檔案總管複製檔案及目錄的範例 |
|
malanlk
尊榮會員 發表:20 回覆:694 積分:577 註冊:2004-04-19 發送簡訊給我 |
在 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 |
本站聲明 |
1. 本論壇為無營利行為之開放平台,所有文章都是由網友自行張貼,如牽涉到法律糾紛一切與本站無關。 2. 假如網友發表之內容涉及侵權,而損及您的利益,請立即通知版主刪除。 3. 請勿批評中華民國元首及政府或批評各政黨,是藍是綠本站無權干涉,但這裡不是政治性論壇! |