利用DELPHI编写WINDOWS外壳

 

利用DELPHI编写WINDOWS外壳

---

　　 对于操作系统原理比较了解的朋友都会知道，一个完备的操作系统都会提供一个外壳（Shell），以方便普通用户使用操作系统提供的各种功能。Windows（在这里指的是Windows 95/Windows NT4.0以上版本的操作系统）的外壳不但提供了方便美观的GUI图形界面，而且还提供了强大的外壳扩展功能，大家可能在很多软件中看到这些外壳扩展了。例如:如果你的系统中安装了Winzip的话，当你在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 object handlers:在文件被拖放、拷贝或者粘贴时，就会被系统被调用。
　　Windows的所有外壳扩展都是基于COM(Component Object Model) 组件模型的，外壳是通过接口(Interface)来访问对象的。外壳扩展被设计成32位的进程中服务器程序，并且都是以动态链接库的形式为操作系统提供服务的。因此，如果要对Windows的用户界面进行扩充的话，则具备写COM对象的一些知识是十分必要的。
　　写好外壳扩展程序后，必须将它们注册才能生效。所有的外壳扩展都必须在Windows注册表的HKEY_CLASSES_ROOT/CLSID键之下进行注册。在该键下面可以找到许多名字像{0000002F－0000－0000－C000－000000000046}的键，这类键就是全局唯一类标识符(Guid)。每一个外壳扩展都必须有一个全局唯一类标识符，Windows正是通过此唯一类标识符来找到外壳扩展处理程序的。在类标识符之下的InProcServer32子键下记录着外壳扩展动态链接库在系统中的位置。与某种文件类型关联的外壳扩展注册在相应类型的shellex主键下。如果所处的Windows操作系统为Windows NT，则外壳扩展还必须在注册表中的HKEY－LOCAL－MACHINE/Software/Microsoft/Windows/CurrentVersion/ShellExtensions/Approved主键下登记。
　　编译完外壳扩展的DLL程序后就可以用Windows本身提供的regsvr32.exe来注册该DLL服务器程序了。如果使用Delphi，也可以在Run菜单中选择Register ActiveX 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, ShellApi, 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;
　　dwAspect := 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 (HiWord(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(TCom Object Factory)
　　public
　　procedure UpdateRegistry(Register: Boolean); override;
　　end;
　　procedure TContextMenuFactory.UpdateRegistry(Register: Boolean);
　　var
　　ClassID: string;
　　begin
　　if Register then begin
　　inherited UpdateRegistry(Register);
　　ClassID := GUIDToString(Class－ContextMenu);
　　//当注册扩展库文件时，添加库到注册表中
　　CreateRegKey('＊/shellex', '', '');
　　CreateRegKey('＊/shellex/ContextMenuHandlers', '', '');
　　CreateRegKey('＊/shellex/ContextMenuHandlers/FileOpreation', '', ClassID);
　　//如果操作系统为Windows NT的话
　　if (Win32Platform = VER－PLATFORM－WIN32－NT) then
　　with TRegistry.Create do
　　try
　　RootKey := HKEY－LOCAL－MACHINE;
　　OpenKey('SOFTWARE/Microsoft/Windows/CurrentVersion/Shell Extensions', True);
　　OpenKey('Approved', True);
　　WriteString(ClassID, 'Context Menu Shell Extension');
　　finally
　　Free;
　　end;
　　end
　　else begin
　　DeleteRegKey('＊/shellex/ContextMenuHandlers/FileOpreation');
　　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、Windows2000，Delphi5下运行通过。