利用DELPHI編寫WINDOWS外殼 (轉)

利用DELPHI編寫WINDOWS外殼 (轉)[@more@] 

利用編寫外殼

---

　　 對於操作原理比較瞭解的朋友都會知道，一個完備的都會提供一個外殼（），以方便普通使用作業系統提供的各種功能。Windows（在這裡指的是Windows 954.0以上版本的作業系統）的外殼不但提供了方便美觀的GUI圖形介面，而且還提供了強大的外殼擴充套件功能，大家可能在很多中看到這些外殼擴充套件了。例如:如果你的系統中了的話，當你在Windows Explore中滑鼠右鍵點選夾或者檔案時，彈出選單中就會出現Winzip的選單。
　　Windows支援七種型別的外殼擴充套件（稱為Handler），它們相應的作用簡述如下：
　　(1)Context menu handlers:向特定型別的檔案增添上下文相關選單；
　　(2)Drag－and－drop handlers:用來支援當使用者對某種型別的檔案物件進行拖放操作時的OLE資料傳輸；
　　(3)Icon handlers:用來向某個檔案物件提供一個特有的圖示，也可以給某一類檔案物件指定圖示；
　　(4)Property sheet handlers:給檔案物件增添屬性頁（就是右鍵點選檔案物件或資料夾物件後，在彈出選單中選屬性項後出現的對話方塊），屬性頁可以為同一類檔案物件所共有，也可以給一個檔案物件指定特有的屬性頁；
　　(5)Copy－hook handlers:在資料夾物件或者印表機物件被複製、移動、刪除和重新命名時，就會被系統，透過為Windows增加Copy－hook handlers，可以允許或者禁止其中的某些操作；
　　(6)Drop target handlers:在一個物件被拖放到另一個物件上時，就會被系統被呼叫；
　　(7)Data handlers:在檔案被拖放、複製或者貼上時，就會被系統被呼叫。
　　Windows的所有外殼擴充套件都是基於COM(Component Object Model) 模型的，外殼是透過介面(Interface)來訪問物件的。外殼擴充套件被設計成32位的程式中，並且都是以動態連結庫的形式為作業系統提供服務的。因此，如果要對Windows的使用者介面進行擴充的話，則具備寫COM物件的一些知識是十分必要的。
　　寫好外殼擴充套件程式後，必須將它們註冊才能生效。所有的外殼擴充套件都必須在Windows登錄檔的HKEY_CLASSES_CLSID鍵之下進行註冊。在該鍵下面可以找到許多名字像{0000002F－0000－0000－C000－000000000046}的鍵，這類鍵就是全域性唯一類識別符號(Guid)。每一個外殼擴充套件都必須有一個全域性唯一類識別符號，Windows正是透過此唯一類識別符號來找到外殼擴充套件處理程式的。在類識別符號之下的InProcServer32子鍵下記錄著外殼擴充套件動態連結庫在系統中的位置。與某種檔案型別關聯的外殼擴充套件註冊在相應型別的shellex主鍵下。如果所處的Windows作業系統為Windows NT，則外殼擴充套件還必須在登錄檔中的HKEY－LOCAL－MACHINESoftwareWindowsCurrentVersionShellExtensionsApproved主鍵下登記。
　　編譯完外殼擴充套件的DLL程式後就可以用Windows本身提供的regsvr32.exe來註冊該DLL伺服器程式了。如果使用Delphi，也可以在Run選單中選擇Register Server來註冊。
　　下面首先介紹一個比較常用的外殼擴充套件應用：上下文相關選單，在Windows中，用滑鼠右鍵單擊檔案或者資料夾時彈出的那個選單便稱為上下文相關選單。要動態地在上下文相關選單中增添選單項，可以透過寫Context Menu Handler來實現。比如大家所熟悉的WinZip和UltraEdit等軟體都是透過編寫Context Menu Handler來動態地向選單中增添選單項的。本文要實現的Context Menu Handler將在任意型別檔案物件的上下文相關選單中新增一個檔案操作選單項，當點選該項後，介面程式就會彈出一個檔案操作視窗，檔案複製、移動等操作。
　　編寫Context Menu Handler必須實現IShellExtInit、IContextMenu和TComObjectFactory三個介面。IShellExtInit實現介面的初始化，IContextMenu介面物件實現上下文相關選單，IComObjectFactory介面實現物件的建立。
　　下面是具體的程式實現。首先在Delphi中點選選單的File|New項，在New Item視窗中選擇DLL建立一個DLL工程檔案。然後點選選單的File|New項，在New Item視窗中選擇Unit建立一個Unit檔案，點選點選選單的File|New項，在New Item視窗中選擇Form建立一個新的視窗。將將工程檔案儲存為Contextmenu.dpr，將Unit1儲存為Contextmenuhandle.pas，將Form儲存為OpWindow.pas。
　　Contextmenu.dpr的程式清單如下：
　　library contextmenu;
　　uses
　　ComServ,
　　contextmenuhandle in 'contextmenuhandle.pas',
　　opwindow in 'opwindow.pas' {Form2};
　　exports
　　DllGetClassObject,
　　DllCanUnloadNow,
　　DllRegisterServer,
　　DllUnregisterServer;
　　{＄R ＊.TLB}
　　{＄R ＊.RES}
　　begin
　　end.
　　Contextmenuhandle的程式清單如下：
　　unit ContextMenuHandle;
　　interface
　　uses Windows,ActiveX,ComObj,ShlObj,Classes;
　　type
　　TContextMenu = class(TComObject,IShellExtInit,IContextMenu)
　　private
　　FFileName: array[0..MAX_PATH] of Char;
　　protected
　　function IShellExtInit.Initialize = SEIInitialize; // Avoid compiler warning
　　function SEIInitialize(pidlFolder: PItemIDList; lpdobj: IDataObject;
　　hKeyProgID: HKEY): HResult; stdcall;
　　function QueryContextMenu(Menu: HMENU; indexMenu, idCmdFirst, idCmdLast,
　　uFlags: UINT): HResult; stdcall;
　　function InvokeCommand(var lpici: TCMInvokeCommandInfo): HResult; stdcall;
　　function GetCommandString(idCmd, uType: UINT; pwReserved: PUINT;
　　pszName: LPSTR; cchMax: UINT): HResult; stdcall;
　　end;
　　const
　　Class_ContextMenu: TGUID = '{19741013－C829－11D1－8233－0020AF3E97A0}';
　　{全域性唯一識別符號(GUID)是一個16位元組（128為）的值，它唯一地標識一個介面(interface)}
　　var
　　FileList:TStringList;
　　implementation
　　uses ComServ, SysUtils, Shell, Registry,UnitForm;
　　function TContextMenu.SEIInitialize(pidlFolder: PItemIDList; lpdobj: IDataObject;
　　hKeyProgID: HKEY): HResult;
　　var
　　StgMedium: TStgMedium;
　　FormatEtc: TFormatEtc;
　　FileNumber,i:Integer;
　　begin
　　//如果lpdobj等於Nil，則本呼叫失敗
　　if (lpdobj = nil) then begin
　　Result := E_INVALIDARG;
　　Exit;
　　end;
　　//首先初始化並清空FileList以新增檔案
　　FileList:=TStringList.Create;
　　 FileList.Clear;
　　//初始化剪貼版格式檔案
　　with FormatEtc do begin
　　cfFormat := CF_HDROP;
　　ptd := nil;
　　dwect := DVASPECT_CONTENT;
　　lindex := －1;
　　tymed := TYMED_HGLOBAL;
　　end;
　　Result := lpdobj.GetData(FormatEtc, StgMedium);
　　if Failed(Result) then Exit;
　　//首先查詢使用者選中的檔案的個數
　　FileNumber := DragQueryFile(StgMedium.hGlobal,＄FFFFFFFF,nil,0);
　　//迴圈讀取，將所有使用者選中的檔案儲存到FileList中
　　for i:=0 to FileNumber－1 do begin
　　DragQueryFile(StgMedium.hGlobal, i, FFileName, SizeOf(FFileName));
　　FileList.Add(FFileName);
　　Result := NOERROR;
　　end;
　　ReleaseStgMedium(StgMedium);
　　end;
　　function TContextMenu.QueryContextMenu(Menu: HMENU; indexMenu, idCmdFirst,
　　idCmdLast, uFlags: UINT): HResult;
　　begin
　　Result := 0;
　　if ((uFlags and ＄0000000F) = CMF－NORMAL) or
　　((uFlags and CMF_EXPLORE) <> 0) then begin
　　// 往Context Menu中加入一個選單項 ,選單項的標題為察看位件
　　InsertMenu(Menu, indexMenu, MF_STRING or MF_BYPOSITION, idCmdFirst,
　　PChar('檔案操作'));
　　// 返回增加選單項的個數
　　Result := 1;
　　end;
　　end;
　　function TContextMenu.InvokeCommand(var lpici: TCMInvokeCommandInfo): HResult;
　　var
　　frmOP:TForm1;
　　begin
　　// 首先確定該過程是被系統而不是被一個程式所呼叫
　　if (Hi(Integer(lpici.lpVerb)) <> 0) then
　　begin
　　Result := E_FAIL;
　　Exit;
　　end;
　　// 確定傳遞的引數的有效性
　　if (LoWord(lpici.lpVerb) <> 0) then begin
　　Result := E_INVALIDARG;
　　Exit;
　　end;
　　//建立檔案操作視窗
　　frmOP:=TForm1.Create(nil);
　　//將所有的檔案列表新增到檔案操作視窗的列表中
　　frmOP.ListBox1.Items := FileList;
　　Result := NOERROR;
　　end;
　　function TContextMenu.GetCommandString(idCmd, uType: UINT; pwReserved: PUINT;
　　pszName: LPSTR; cchMax: UINT): HRESULT;
　　begin
　　 if (idCmd = 0) then begin
　　 if (uType = GCS_HELPTEXT) then
　　{返回該選單項的幫助資訊，此幫助資訊將在使用者把滑鼠
　　移動到該選單項時出現在狀態條上。}
　　StrCopy(pszName, PChar('點選該選單項將執行檔案操作'));
　　Result := NOERROR;
　　end
　　else
　　Result := E_INVALIDARG;
　　end;
　　type
　　TContext Menu Factory =class(TObject Factory)
　　public
　　procedure UpdateRegistry(Register: Boolean); overr;
　　end;
　　procedure TContextMenuFactory.UpdateRegistry(Register: Boolean);
　　var
　　ClassID: string;
　　begin
　　if Register then begin
　　inherited UpdateRegistry(Register);
　　ClassID := GUIDToString(Class－ContextMenu);
　　//當註冊擴充套件庫檔案時，新增庫到登錄檔中
　　CreateRegKey('＊shellex', '', '');
　　CreateRegKey('＊shellexContextMenuHandlers', '', '');
　　CreateRegKey('＊shellexContextMenuHandlersFileOpreation', '', ClassID);
　　//如果作業系統為Windows NT的話
　　if (Platfo= VER－PLATFORM－WIN32－NT) then
　　with TRegistry.Create do
　　try
　　RootKey := HKEY－LOCAL－MACHINE;
　　OpenKey('SOFTWAREMicrosoftWindowsCurrentVersionShell Extensions', True);
　　OpenKey('Approved', True);
　　WriteString(ClassID, 'Context Menu Shell Extension');
　　finally
　　Free;
　　end;
　　end
　　else begin
　　DeleteRegKey('＊shellexContextMenuHandlersFileOpreation');
　　inherited UpdateRegistry(Register);
　　end;
　　end;
　　initialization
　　TContext Menu Factory.Create(Com Server, TContextMenu, Class－ContextMenu,'', 'Context Menu Shell Extension', ciMultiInstance,tmApartment);
　　end.
　　在OpWindow視窗中加入一個TListBox和兩個TButton控制元件，OpWindows.pas的程式清單如下：
　　unit opwindow;
　　
　　interface
　　uses
　　Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
　　ExtCtrls, StdCtrls,shlobj,shellapi,ActiveX;
　　type
　　TForm1 = class(TForm)
　　ListBox1: TListBox;
　　Button1: TButton;
　　Button2: TButton;
　　procedure FormCreate(Sender: TObject);
　　procedure FormClose(Sender: TObject; var Action: TCloseAction);
　　procedure Button1Click(Sender: TObject);
　　procedure Button2Click(Sender: TObject);
　　private
　　{ Private declarations }
　　public
　　 FileList:TStringList;
　　{ Public declarations }
　　end;
　　var
　　 Form1: TForm1;
　　implementation
　　{＄R ＊.DFM}
　　procedure TForm1.FormCreate(Sender: TObject);
　　begin
　　FileList:=TStringList.Create;
　　Button1.Caption :='複製檔案';
　　Button2.Caption :='移動檔案';
　　Self.Show;
　　end;
　　procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
　　begin
　　FileList.Free;
　　end;
　　procedure TForm1.Button1Click(Sender: TObject);
　　var
　　sPath:string;
　　fsTemp:SHFILEOPSTRUCT;
　　i:integer;
　　begin
　　sPath:=InputBox('檔案操作','輸入複製路徑','c:windows');
　　if sPath<>''then begin
　　fsTemp.Wnd := Self.Handle;
　　//設定檔案操作型別
　　fsTemp.wFunc :=FO_COPY;
　　//允許執行撤消操作
　　fsTemp.fFlags :=FOF－ALLOWUNDO;
　　for i:=0 to ListBox1.Items.Count－1 do begin
　　//原始檔全路徑名
　　fsTemp.pFrom := PChar(ListBox1.Items.Strings[i]);
　　//要複製到的路徑
　　fsTemp.pTo := PChar(sPath);
　　fsTemp.lpszProgressTitle:='複製檔案';
　　if SHFileOperation(fsTemp)<>0 then
　　ShowMessage('檔案複製失敗');
　　end;
　　end;
　　end;
　　procedure TForm1.Button2Click(Sender: TObject);
　　var
　　sPath:string;
　　fsTemp:SHFILEOPSTRUCT;
　　i:integer;
　　begin
　　sPath:=InputBox('檔案操作','輸入移動路徑','c:windows');
　　if sPath<>''then begin
　　fsTemp.Wnd := Self.Handle;
　　fsTemp.wFunc :=FO_MOVE;
　　fsTemp.fFlags :=FOF_ALLOWUNDO;
　　for i:=0 to ListBox1.Items.Count－1 do begin
　　fsTemp.pFrom := PChar(ListBox1.Items.Strings[i]);
　　fsTemp.pTo := PChar(sPath);
　　fsTemp.lpszProgressTitle:='移動檔案';
　　if SHFileOperation(fsTemp)<>0 then
　　ShowMessage('檔案複製失敗');
　　end;
　　end;
　　end;
　　end.
　　點選選單的Project|Build ContextMenu項，Delphi就會建立Contextmenu.dll檔案，這個就是上下文相關選單程式了。
　　使用Regsvr32.exe註冊程式，然後在Windows的Explore中在任意的一個或者幾個檔案中點選滑鼠右鍵，在上下文選單中就會多一個檔案操作的選單項，點選該項，在彈出視窗的列表中會列出你所選擇的所有檔案的檔名，你可以選擇複製檔案按鈕或者移動檔案按鈕執行檔案操作。
　　以上程式在Windows98、，Delphi5下執行透過。