Windows 外壳扩展编程入门实例

—— Delphi 篇

作者的话

关于Windows 外壳扩展方面的文章私心以为最好的应当算是Michael Dunn 的TheComplete Idiot’s Guide to Writing Shell Extensions 我也曾想过所谓眼前有景道不得崔颢题诗在上头既然已经有了这么好的文章我还来饶舌算什么不过转念再想文章虽好毕竟是为Visual C++的用户看的对Delphi 的使用者来说似乎有点不公平我最初编写Shell Extension 的时候用的也是Visual C++ 不过现在已经转而使用Delphi 觉得两者毕竟还是有所不同因此就有了这篇文章算是将我的一些心得体会和大家分享我最初的打算是将Michael Dunn 文章中涉及的全部内容全部转成Delphi 程序再加上我自己的一些发现做成一个完整的系列不过后来发现这个工程量实在相当的大而且似乎没有必要因为Windows Shell Extension 的许多内容是相通的完全可以举一反三我再重复MSDN或者Michael Dunn 文章中的那些东西似乎是在浪费时间最终我决定只用一个例子说明Shell Extension 编程的基本原理就好至于后面的东西那就修行在各人了我是第一次写这样长的文章而且从文字程序到图片样样俱全加上Acrobat 又不熟悉用法所以做的比较辛苦如果有什么意见或是发现问题的话欢迎来信告诉我(Hao.Yu@yeah.net) 不过我无法保证一定能够回信如果想要转载的话也无妨不过希望能够尊重我的劳动不要擅自修改文章内容也不要改头换面署上自己的名字再次感谢您费心

(2002 年5 月3 日)

第一篇概述

尽管Windows 资源管理器的功能在每个新版本中都得到了不少增强还是有许多人对它感到不满意有没有办法让资源管理器变得更好用更符合自己的需要呢一个办法就是自己重新打造一个全新的Explorer 目前已经有了一些这方面的软件比如PowerDesk Utilities 和Turbo Browser 就堪称个中翘楚不过要完全实现资源管理器方方面面的功能其工作量可能超乎想象而且牵涉的知识面颇广对个人来说难度高了一些而另一个办法就是利用Microsoft 开放给我们的外壳扩展接口了虽然这种途径限制更多一些但是门槛比较低而且也能够满足绝大部分需要这方面一个最好的例子就是WinZip 这个软件几乎把外壳扩展的功能发挥到了极致相信你已经很熟悉它了在本文中我就利用自己完成的一个实际的例子来说明如何编程扩展Windows 外壳为了完成这个例子我参考了一些资料主要是Michael Dunn的The Complete Idiot'sGuide to Writing Shell Extensions 可以从http://www.codeproject.com/shell/ 得到这个系列的文档这是我看到的最好的介绍外壳扩展编程的文章感谢Michael Dunn 不过他的例子是用Visual C++编写的我在阅读的时候就感到用Visual C++来编写这些东西显得太过繁琐而且将MFC/ATL/STL 混合在一起的风格也让我觉得非常不爽因此后来我改用Delphi 重写了程序这样确实为我节省了不少工作量如果你常用的工具是Visual C++ 那

么建议你还是应该去阅读Michael Dunn 的文档这些文档内容更完整得多我的这篇文章主要是面对Delphi 的用户提供一个入门级的Windows 外壳扩展编程指导我用来编写这个程序的平台是Microsoft Windows 2000 Professional 编程工具是BorlandDelphi 6.0+Update Pack 2 在编写外壳扩展程序的时候我推荐尽可能使用最新的开发平台因为Windows Shell 的接口总是在持续的更新而比较老的开发平台例如Delphi 5.0和更早的Visual C++ 6.0 将无法识别许多新的结构接口和函数等等虽然我听到不少抱怨说Delphi 6.0 不如早期版本来的稳定不过至少在开发这个程序的过程中它并没有给我造成什么麻烦至于操作系统无论如何要用Windows 2000 因为在Windows 9X 下调试外壳扩展是一件非常麻烦的事情

在编写外壳扩展之前应该先做一些准备工作首先必须在注册表中作一些改动因为任何外壳扩展都是作为DLL 而加载到Explorer 的进程空间内的所以如果不做些手脚那么只要Explorer还存在你编写的外壳扩展就无法顺利编译如果你愿意手动修改注册表的话可以参考Michael

Dunn 的文章不过我建议你利用Windows 优化大师这个软件帮你做掉这项工作只要选中启动系统时为桌面和Explorer 创建独立的进程即可这个选项会增加一些系统开销不过从理论上来讲倒是可以让操作系统更稳定一些如下图所示另外一个问题就是在调试外壳扩展的时候你不能太依赖于集成调试器就拿ContextMenu 扩展来说你怎么能一方面激活集成调试器另一方面又让资源管理器中的上下文菜单保持可见呢所以你首先应该养成在运行程序之前把程序先好好检查一遍的习惯不要急着按F9 其次如果你需要一个脱离IDE 又能够显示调试信息的工具那么有一个很好的工具DebugView 可以满足你这个软件可以从www.sysinternals.com 取得我发现这个工具至少能够解决90%以上的调试需求它已经成为我的编程工具箱中最重要的工具之一最后再罗索两句编写外壳扩展的时候一定要特别小心尽量处理任何可能发生的错误因为外壳扩展是被Explorer加载到进程空间内的所以外壳扩展中的任何错误都可能让Explorer崩溃掉特别是你的程序中如果用到任何VCL 类或者RTL 函数的话一定要处理掉可能发生的异常因为操作系统并不知道如何处理VCL/RTL 异常其后果如何是可想而知的考虑到Explorer在系统中的地位你应该有一种如临深渊如履薄冰的感觉了另外为了用户考虑外壳扩展所执行的任何任务都应该尽可能快的完成决不要用外壳扩展执行那些需要很长时间的动作否则的话如果用户在资源管理器中点击鼠标后要好几秒钟才会看到菜单出现那么很快他们她们就会感到不耐烦进而对你的软件失去信心准备好了吗我们出发吧

第二篇建立程序框架

外壳扩展有好几种类型在这里我要实现的是一个Context Menu 扩展因为这是最常见最有用的扩展类型而且所有的外壳扩展都有许多相通的地方学会一种以后其他的也就非常容易掌握了我计划让这个扩展完成如下的一些功能

1 对任何文件都能够实现Copy(Move) to Anywhere Windows 资源管理器并不直接支持这项功能不论是Cut/Copy&Paste 或者是开两个文件夹窗口来Drag/Drop 都要经历多个步骤才行毕竟麻烦我是在工具软件Nuts & Bolt中第一次看到这个功能的当时就觉得它非常有用不过一直不知道是如何实现的现在好了我们也来DIY 一回

2 对于COM 组件库能够实现Register/Unregister 的功能凡是编程的人都应该知道这个内容从而不必动用不讨人喜欢的regsvr32

3 对于图片文件能够在Context Menu 中预览用过PicaView 吗对了就是它如果只是想知道图片的概貌又何必非ACDSee 不可Windows 2000 的

缩略图模式处理图像太慢而且占用太多资源我也不喜欢上述三种情况几乎涵盖了Context Menu 扩展所能遇到的所有情况如何处理单一文件

如何处理多个文件如何管理自绘式Owner-Draw 菜单可以说只要能妥善处理这三种情况那么在Context Menu 扩展中再没有什么困难的问题了

因为任何外壳扩展首先必须是一个COM 组件所以我们就从这里开始1 用Delphi 新建一个ActiveX Library 并保存我用的名称是YHShellExt 你当然可以猜到YH是我的名字的缩写你可以把它换成自己的名字

2 再次用Delphi 新建一个COM Object 在COM Object Wizard 中将对象命名为YHContextMenu Options 中的两个检查框都可以不必选中其他的保持默认即可

现在这个程序的框架已经建立起来了Delphi 为我们自动产生了TYHContextMenu 类的骨架代码并且在单元的initialization 部分自动产生了一个TComObjectFactory 对象这个对象可以完成COM组件的注册工作不过对于外壳扩展来说除了注册COM组件之外还必须完成一些额外的工作这个组件才具备了外壳扩展的身份所以我们还需要从TComObjectFactory 派生一个类才行对代码稍作修改完成后应该类似下面这样

unit YHCMImpl;

interface

uses

Windows, Messages, ActiveX, Classes, SysUtils, ComObj, ShellAPI, ShlObj,

Graphics, JPEG, Registry;

type

{

TYHContextMenu - Context Menu Extension 的实现类

}

TYHContextMenu = class(TComObject)

private

protected

public

end;

{

TYHContextMenuFactory - Context Menu Extension 的类工厂

}

TYHContextMenuFactory = class(TComObjectFactory)

public

procedure UpdateRegistry(Register: Boolean); override;

end;

const

Class_YHContextMenu: TGUID = '{461BCDC0-5E20-11D6-9A8D-

00E04C393F6F}';

implementation

uses ComServ;

//===============================================

// TYHContextMenu

//===============================================

//===============================================

// TYHContextMenuFactory

//===============================================

procedure TYHContextMenuFactory.UpdateRegistry(Register: Boolean);

begin

inherited;

end;

initialization

TYHContextMenuFactory.Create(ComServer, TYHContextMenu,

Class_YHContextMenu, 'YHContextMenu', '', ciMultiInstance, tmApartment);

end.

建立程序框架的工作到此完成从下一部分开始我们将陆续向程序中加入功能性的代码

第三篇支持I S h e l l E x t I n i t 接口

绝大多数外壳扩展都需要支持IShellExtInit 接口除此之外每一种扩展分别还需要支持一至二个额外的接口对于Context Menu 扩展来说必须支持的两个基本接口就是IShellExtInit 和IContextMenu 另外如果要处理自绘式菜单还需要支持IContextMenu2或者IContextMenu3 由于IShellExtInit 接口对每一个外壳扩展来说都是必需的而且相对简单我们首先来实现它IShellExtInit 接口只有一个方法Initialize 在Context Menu 弹出之前系统会调用这个方法而我们所要做的工作就是在这个时候决定用户究竟选定了哪些文件再根据这些文件的类型做进一步的处理不过这里有一个小小的麻烦在Delphi 中一切COM 对象都是从TComObject 派生而来的而TComObject 类中已经有了一个虚拟的Initialize 方法这个方法会在COM组件建立的时候被调用如果我们的程序还要实现IShellExt::Initialize 的话那么命名冲突的问题就不可避免了怎么办Object Pascal 中有一种特殊的语法可以避开这个问题

TYHContextMenu = class(TComObject, IShellExtInit)

private

{ 数据成员}

FFileList : TStringList;

FGraphic : TGraphic;

protected

{ IShellExtInit 接口}

function IShellExtInit.Initialize = SEInitialize;

function SEInitialize(pidlFolder: PItemIDList; lpdobj: IDataObject;

hKeyProgID: HKEY): HResult; stdcall;

public

procedure Initialize; override;

destructor Destroy; override;

end;

基本上Object Pascal 语言采用的是单根继承的方法所以命名冲突的问题很少会出现不过一旦某个类需要实现多个接口那么还是无法确保这些接口不会有同名的方法不过你也看到了只要像上述那样为其中某个接口的方法另外起一个名字就不会有问题了为了正确处理外壳扩展的构造/析构动作我重载了TComObject 的Initialize 和Destroy两个方法你或许会奇怪为什么不重载Create 而用了Initialize 这是因为TComObject 有好几种形式的构造函数但是不论如何构造TComObject Initialize 方法是一定会被调用的所以这里是执行初始化动作的最好地方另外注意我添加了两个数据成员其中FFileList 用于保存用户选中的文件列表FGraphic 用于执行图片预览的动作在后面我们会用到Initialize 和Destroy 方法的代码非常简单无非是数据的初始化和释放而已

procedure TYHContextMenu.Initialize;

begin

OutputDebugString('YHContextMenu::Initialize'#13#10);

inherited;

FFileList := TStringList.Create;

FGraphic := nil;

end;

destructor TYHContextMenu.Destroy;

begin

OutputDebugString('YHContextMenu::Destroy'#13#10);

FreeAndNil(FFileList);

FreeAndNil(FGraphic);

inherited;

end;

上面两个OutputDebugString 的作用是观察Context Menu 扩展的生存周期用DebugView 可以看到Context Menu 扩展在资源管理器中点击右键弹出上下文菜单的时候才会建立而菜单消失的时候生命也就结束了如下图当然现在还无法看到这个结果因为这个扩展还没有实现IContextMenu 所以根本还不是一个合法的Context MenuExtension 但是从中你可以看到DebugView 在调试过程中的作用下一步是实现IShellExtInit::Initialize 这个方法包括三个参数不过目前来说有用的只有一个就是系统传递给我们的IDataObject 对象我们可以从中获得用户选择的文件列表因为对于所有的外壳扩展来说对此一方法的处理都相当一致所以我设计了另外一个方法这个方法可以被任何实现IShellExtInit 的类所调用

//===============================================

// IShellExtInit::Initialize

//===============================================

function TYHContextMenu.SEInitialize(pidlFolder: PItemIDList;

lpdobj: IDataObject; hKeyProgID: HKEY): HResult;

begin

Result := GetFileListFromDataObject(lpdobj, FFileList);

end;

function GetFileListFromDataObject(lpdobj: IDataObject; sl: TStringList) : HResult;

var

fe : FormatEtc;

sm : StgMedium;

i, iFileCount : integer;

FileName : array[0..MAX_PATH-1] of char;

begin

assert(lpdobj<>nil);

assert(sl<>nil);

sl.Clear;

with fe do begin

cfFormat := CF_HDROP;

ptd := nil;

dwAspect := DVASPECT_CONTENT;

lindex := -1;

tymed := TYMED_HGLOBAL;

end;

with sm do begin

tymed := TYMED_HGLOBAL;

end;

Result := lpdobj.GetData(fe, sm);

if Failed(Result) then Exit;

iFileCount := DragQueryFile(sm.hGlobal, $ffffffff, nil, 0);

if iFileCount<=0 then begin

ReleaseStgMedium(sm);

Result := E_INVALIDARG;

Exit;

end;

for i:=0 to iFileCount-1 do begin

DragQueryFile(sm.hGlobal, i, FileName, sizeof(FileName));

sl.Add(FileName);

end;

ReleaseStgMedium(sm);

Result := S_OK;

end;

对IDataObject 的处理涉及COM 中特别是OLE 拖放编程的一些高级概念所以上面的代码可能会让缺乏这方面知识的人看起来有点糊涂不过没关系你只需要知道调用这个方法以后用户选择的文件列表就会保存到StringList 中就行了在这一部分我们除了处理外壳扩展本身的初始化和清除之外还实现了IShellExtInit 接口在下一部分我们将进入Context Menu 扩展的另外一个也是最核心的接口IContextMenu

第四篇支持I C o n t e x t M e n u 接口

比起我们在上面讨论的IShellExtInit 接口来说IContextMenu 是一个相对复杂的接口它有三个方法而且每个方法都是参数众多虽然InvokeCommand 方法只有一个参数不过这个参数可是一个相当庞大的结构我们按顺序来首先是菜单弹出之前系统要调用的方法

QueryContextMenu

QueryContextMenu 方法声明如下

function QueryContextMenu(Menu: HMENU;

indexMenu, idCmdFirst, idCmdLast, uFlags: UINT): HResult; stdcall;

其中Menu 就是系统开放给你的上下文菜单的句柄你可以用InsertMenu 或者InsertMenuItem之类的函数向里面增加菜单indexMenu 是系统预留给你的菜单项的位置你应该从这个位置开始加入菜单但是加入的菜单项个数不要超过idCmdLast-idCmdFirst 这个范围uFlags 则是一些标志位函数的返回值则应该是你加入的菜单个数和其他一些标志的组合例如我们要加入一个CopyAnywhere 的菜单项

const

// 菜单类型

mfString = MF_STRING or MF_BYPOSITION;

mfOwnerDraw = MF_OWNERDRAW or MF_BYPOSITION;

mfSeparator = MF_SEPARATOR or MF_BYPOSITION;

// 菜单项ID

idCopyAnywhere = 0; // 复制移动

idRegister = 5; // 注册ActiveX

idUnregister = 6; // 取消注册ActiveX

idImagePreview = 10; // 预览图片文件

idMenuRange = 90;

function Make_HResult(sev, fac, code: Word): DWord;

begin

Result := (sev shl 31) or (fac shl 16) or code;

end;

function TYHContextMenu.QueryContextMenu(Menu: HMENU; indexMenu,

idCmdFirst, idCmdLast, uFlags: UINT): HResult;

var

Added : UINT;

begin

if (uFlags and CMF_DEFAULTONLY)=CMF_DEFAULTONLY then begin

Result := Make_HResult(SEVERITY_SUCCESS, FACILITY_NULL, 0);

Exit;

end;

Added := 0;

// 加入CopyAnywhere 蔡单项

InsertMenu(Menu, indexMenu, mfSeparator, 0, nil);

InsertMenu(Menu, indexMenu, mfString, idCmdFirst+idCopyAnywhere,

PChar(sCopyAnywhere));

InsertMenu(Menu, indexMenu, mfSeparator, 0, nil);

Inc(Added, 3);

Result := Make_HResult(SEVERITY_SUCCESS, FACILITY_NULL,

idMenuRange);

end;

你也许会感到吃惊我分明只加入了一个有效的菜单项即使算上另外两个Separator 也不过3 个而已为什么返回值却指定了90 个之多这是因为我计划编写的是一个通用的Context Menu 扩展它对所有的文件都适用当然为某一种文件编写Context Menu 扩展也是完全可以的不过这样做灵活性太差比如.DLL 或者.OCX 甚至还包括.EXE 都可能是COM组件都可以执行Register/Unre gister的操作难道为了实现同一个功能还要写2~3个基本上没有差别的扩展通用扩展就没有这样的问题不过编程的复杂性就大大增加因为就必须处理这样麻烦的情况如果是.TXT 文件的话需要加入这些菜单如果是.BMP 的话加入另外一些… 为了避免总是要动态计算菜单ID 的麻烦保证扩展的扩充性多保留几个ID 没有坏处在MSDN 中声明返回值应该是加入的菜单项个数+1 严格来说这是不正确的我测试的结果证明返回的结果应该是系统为你的扩展保留的菜单ID 范围也就是说如果idCmdFirst=20000 而你返回了90 那么系统会保证20000~20000+ 90-1 这个范围内的菜单ID 都是可用的如果系统中还有其他扩展的话那么它们会使用20090 后面的菜单ID 所以我总是倾向于保留尽可能多的ID 留给以后使用只要不超过idCmdLast-idCmdFirst 这个限度即可从上面的常量定义你大概也可以发现我使用的规则那就是为每一种文件类型至少保留5 个菜单ID你还会注意到Make_HResult 函数这在SDK 中是作为MAKE_HRESULT 宏来实现的但是Delphi 中并没有宏的概念为了让熟悉SDK 的人更容易理解这个程序我把它拿出来做

成了一个独立的函数

下面一个方法是IContextMenu::InvokeCommand 这个函数会在用户点击菜单项的时

候被调用也是执行真正动作的地方

function TYHContextMenu.InvokeCommand(var lpici:

TCMInvokeCommandInfo): HResult;

begin

Result := E_INVALIDARG;

if HiWord(Integer(lpici.lpVerb))<>0 then Exit;

case LoWord(Integer(lpici.lpVerb)) of

idCopyAnywhere:

DoCopyAnywhere(lpici.hwnd, FFileList);

Result := NOERROR;

end;

procedure DoCopyAnywhere(Wnd: HWND; sl: TStringList);

var

frm : TfrmCopyAnywhere;

begin

frm := TfrmCopyAnywhere.Create(Application);

try

frm.AddFiles(sl);

frm.ShowModal;

finally

frm.Free;

end;

end;

frmCopyAnywhere 是额外设计来实现Copy(Move) to Anywhere 功能的用户界面因为有了SHFileOperation 这样好用的函数所以我们要做的工作其实相当的少这个窗体的详细代码我也就不再列出了相信有点经验的朋友都应该可以轻松完成才对下图是这个窗体的显示界面我的界面设计实在算不上高明希望大家可以设计的比我更好OK 我们已经胜利在望了最后一个需要编写的方法是GetCommandString 当用户选择菜单项的时候在资源管理器的状态栏上会显示相关的提示信息这个方法也没有什么好说的唯一需要注意的就是Unicode/Ansi的区别让事情变得有点复杂不过比起C++来说不管是烦人的MultiByteToWideChar/WideCharToMultiByte 还是我总也搞不清楚的ATLConversions Delphi 的处理过程还是相当简单而直观的

//===============================================

// IContextMenu::GetCommandString

//===============================================

function TYHContextMenu.GetCommandString(idCmd, uType: UINT;

pwReserved: PUINT; pszName: LPSTR; cchMax: UINT): HResult;

var

strTip : string;

wstrTip : WideString;

begin

strTip := '';

Result := E_INVALIDARG;

if (uType and GCS_HELPTEXT)<>GCS_HELPTEXT then Exit;

case idCmd of

idCopyanywhere: strTip := sCopyAnywhereTip;

end;

if strTip<>'' then begin

if (uType and GCS_UNICODE)=0 then begin // Ansi

lstrcpynA(pszName, PChar(strTip), cchMax);

end

else begin // Unicode

wstrTip := strTip;

lstrcpynW(PWideChar(pszName), PWideChar(wstrTip), cchMax);

end;

Result := S_OK;

end;

end;

大功告成不过我们似乎还高兴的早了一点别忘了还有一个TYHContextMenuFactory呢如果忘了它那么期待已久的Context Menu Extension 还是无法出现好在Delphi 有几个非常好用的函数可以省掉处理注册表的许多麻烦

procedure TYHContextMenuFactory.UpdateRegistry(Register: Boolean);

procedure DeleteRegValue(const Path, ValueName: string; Root:

DWord=HKEY_CLASSES_ROOT);

var

reg : TRegistry;

begin

reg := TRegistry.Create;

with reg do

try

RootKey := Root;

if OpenKey(Path, False) then begin

if ValueExists(ValueName) then

DeleteValue(ValueName);

CloseKey;

end;

finally

Free;

end;

end;

const

RegPath = '*\shellex\ContextMenuHandlers\YHShellExt ';

ApprovedPath = 'Software\Microsoft\Windows\CurrentVersion\Shell

Extensions\Approved';

var

strGUID : string;

begin

inherited;

strGUID := GUIDToString(Class_YHContextMenu);

if Register then begin

CreateRegKey(RegPath, '', strGUID);

CreateRegKey(ApprovedPath, strGUID, 'YH 的外壳扩展',

HKEY_LOCAL_MACHINE);

end

else begin

DeleteRegKey(RegPath);

DeleteRegValue(ApprovedPath, strGUID, HKEY_LOCAL_MACHINE);

end;

end;

现在我们面对的就是一个真真正正的可以执行的Context Menu 外壳扩展了只要在IDE 中执行一下Run- >Register ActiveX Server 命令你就能够到资源管理器中检阅自己的劳动成果了

第五篇加入注册/ 反注册A c t i v e X L i b r a r y 的功能

上面的内容都明白了吗如果你回答是那么这一部分的内容对你来说也应该是轻而易举的了为了简化起见我决定只支持单一文件的注册和反注册功能注册和反注册的原理也是非常简单的用LoadLibrary 载入ActiveX 连接库并且查找是否存在DllRegisterServer或者DllUnregisterServer 这两个函数如果有则执行之所以代码没有什么好解释的唯一不同之处在于我为这两个菜单项加入了图像利用SetMenuItemBitmaps 函数这两个图像是作为资源连接到最终的DLL 中的如果你还不明白怎样在Delphi 程序中加入资源那么我就简要说明一下

1 准备好两个14*14 的小图像如果不嫌麻烦的话也不妨用GetMenuCheckMarkDimensions 函数确认一下是否为这个大小

2 建立一个文本文件修改它的内容如下

101 BITMAP "reg.bmp"

102 BITMAP "unreg.bmp"

然后把它保存为ExtraRes.rc 使用其他名称亦可但不要和项目重名

3 从IDE 菜单中选择Project->Add to Project 将文件类型改为Resource

File(*.rc) 选择刚才保存的.RC 文件即可

resourcestring

// 菜单标题和提示字符串资源

sCopyAnywhere = '复制到...';

sCopyAnywhereTip = '将选定的文件复制到任何路径下';

sRegister = '注册...';

sRegisterTip = '注册ActiveX 库';

sUnregister = '取消注册...';

sUnregisterTip = '取消注册ActiveX 库';

sImagePreview = '预览图片文件';

sImagePreviewTip = '预览图片文件';

function TYHContextMenu.QueryContext Menu(Menu: HMENU; indexMenu,

idCmdFirst, idCmdLast, uFlags: UINT): HResult;

var

Added : UINT;

hbmReg, hbmUnreg : HBITMAP;

begin

if (uFlags and CMF_DEFAULTONLY)=CMF_DEFAULTONLY then begin

Result := Make_HResult(SEVERITY_SUCCESS, FACILITY_NULL, 0);

Exit;

end;

Added := 0;

// 加入CopyAnywhere 菜单项的代码略

…

if FFileList.Count=1 then begin // 单一文件

if IsActiveLib(FFileList[0]) then begin // AcitveX Library

InsertMenu(Menu, indexMenu+Added, mfSeparator, 0, nil);

InsertMenu(Menu, indexMenu+Added, mfString, idCmdFirst+idUnregister,

PChar(sUnregister));

InsertMenu(Menu, indexMenu+Added, mfString, idCmdFirst+idRegister,

PChar(sRegister));

InsertMenu(Menu, indexMenu+Added, mfSeparator, 0, nil);

Inc(Added, 4);

hbmReg := LoadImage(HInstance, MakeIntResource(101), IMAGE_BITMAP,

0, 0, LR_LOADMAP3DCOLORS);

hbmUnreg := LoadImage(HInstance, MakeIntResource(102),

IMAGE_BITMAP, 0, 0, LR_LOADMAP3DCOLORS);

SetMenuItemBitmaps(Menu, idCmdFirst+idRegister, MF_BYCOMMAND,

hbmReg, hbmReg);

SetMenuItemBitmaps(Menu, idCmdFirst+idUnregister, MF_BYCOMMAND,

hbmUnreg, hbmUnreg);

end;

end

else begin // 多个文件

end;

Result := Make_HResult(SEVERITY_SUCCESS, FACILITY_NULL, idMenuRange);

end;

//=================================================

// IContextMenu::InvokeCommand

//=================================================

function TYHContextMenu.InvokeCommand(var lpici: TCMInvokeCommandInfo):

HResult;

begin

Result := E_INVALIDARG;

if HiWord(Integer(lpici.lpVerb))<>0 then Exit;

case LoWord(Integer(lpici.lpVerb)) of

idCopyAnywhere:

DoCopyAnywhere(lpici.hwnd, FFileList);

idRegister:

RegisterActiveLib(lpici.hwnd, FFileList[0]);

idUnregister:

UnregisterActiveLib(lpici.hwnd, FFileList[0]);

end;

Result := NOERROR;

end;

//=================================================

// IContextMenu::GetCommandString

//=================================================

function TYHContextMenu.GetCommandString(idCmd, uType: UINT;

pwReserved: PUINT; pszName: LPSTR; cchMax: UINT): HResult;

var

strTip : string;

wstrTip : WideString;

begin

strTip := '';

Result := E_INVALIDARG;

if (uType and GCS_HELPTEXT)<>GCS_HELPTEXT then Exit;

case idCmd of

idCopyanywhere: strTip := sCopyAnywhereTip;

idRegister: strTip := sRegisterTip;

idUnregister: strTip := sUnregisterTip;

end;

if strTip<>'' then begin

if (uType and GCS_UNICODE)=0 then begin // Ansi

lstrcpynA(pszName, PChar(strTip), cchMax);

end

else begin // Unicode

wstrTip := strTip;

lstrcpynW(PWideChar(pszName), PWideChar(wstrTip), cchMax);

end;

Result := S_OK;

end;

end;

其中用到了三个辅助函数IsActiveLib RegisterActiveLib 和UnregisterActiveLib 它们

的实现代码如下

function IsActiveLib(const FileName: string): Boolean;

var

Ext : string;

hLib : THandle;

begin

Result := False;

Ext := UpperCase(ExtractFileExt(FileName));

if (Ext<>'.EXE') and (Ext<>'.DLL') and (Ext<>'.OCX') then Exit;

hLib := LoadLibrary(PChar(FileName));

if hLib=0 then Exit;

if GetProcAddress(hLib, 'DllRegisterServer')<>nil then

Result := True;

FreeLibrary(hLib);

end;

procedure RegisterActiveLib(Wnd: HWND; const FileName: string);

var

hLib : THandle;

fn : TDllRegisterServer;

hr : HResult;

begin

hLib := LoadLibrary(PChar(FileName));

if hLib=0 then begin

ReportWin32Error(Wnd, '装载文件失败', GetLastError);

Exit;

end;

fn := TDllRegisterServer(GetProcAddress(hLib, 'DllRegisterServer'));

if not Assigned(fn) then begin

MessageBox(Wnd, ' 定位函数入口点DllRegisterServer 失败', ' 错误',

MB_ICONEXCLAMATION);

FreeLibrary(hLib);

Exit;

end;

hr := fn();

if Failed(hr) then begin

ReportWin32Error(Wnd, '注册动态库失败', hr);

FreeLibrary(hLib);

Exit;

end;

MessageBox(Wnd, '注册成功!', '成功', MB_ICONINFORMATION);

FreeLibrary(hLib);

end;

procedure UnregisterActiveLib(Wnd: HWND; const FileName: string);

var

hLib : THandle;

fn : TDllUnregisterServer;

hr : HResult;

begin

hLib := LoadLibrary(PChar(FileName));

if hLib=0 then begin

ReportWin32Error(Wnd, '装载文件失败', GetLastError);

Exit;

end;

fn := TDllUnregisterServer(GetProcAddress(hLib, 'DllUnregisterServer'));

if not Assigned(fn) then begin

MessageBox(Wnd, ' 定位函数入口点DllUnregisterServer 失败', ' 错误',

MB_ICONEXCLAMATION);

FreeLibrary(hLib);

Exit;

end;

hr := fn();

if Failed(hr) then begin

ReportWin32Error(Wnd, '取消注册动态库失败', hr);

FreeLibrary(hLib);

Exit;

end;

MessageBox(Wnd, '取消注册成功!', '成功', MB_ICONINFORMATION);

FreeLibrary(hLib);

end;

procedure ReportWin32Error(Wnd: HWND; const Prefix: string; dwError: DWord);

var

szError : array[0..399] of char;

str : string;

begin

FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM,

nil, dwError,

Make_LangID(LANG_NEUTRAL, SUBLANG_DEFAULT),

szError, sizeof(szError), nil);

str := Format('%s: %s', [Prefix, StrPas(szError)]);

MessageBox(Wnd, PChar(str), '错误', MB_ICONEXCLAMATION);

end;

想看看带位图的菜单是什么样子吗下图就是弹出菜单的效果

第六篇加入图像预览功能

能够在Context Menu 中预览图像初看起来颇为神奇— — 这也是为什么许多人记住了软件PicaView 的原因IContextMenu 接口虽然能够加入普通的菜单项却无法处理Owner- Draw的菜单即使用MF_OWNERDRAW 参数调用InsertMenu 也不行因为自绘菜单的处理最终要依靠Explorer 窗口来进行而IContextMenu 并没有开放给你这样一条途径可以截获窗口过程对菜单的处理在我看来这实在是IContextMenu 设计上的一个疏漏因为Owner- Draw菜单行之早已有年IContextMenu 的设计者本不应该忘了这一点系统中后来加入的IContextMenu2 和IContextMenu3 也颇为古怪它们都只有一个方法而且除了一个用于返回值的参数之外更无二致令人不禁怀疑Windows Shell Extension 的设计者是否都是丢三

拉四的人否则何以对这样一个小功能的支持都要到3 代猜测归猜测我们还是来看点实际的东西微软的程序员虽然设计了IContextMenu2 但是它似乎从来没有起过作用不论怎样支持IContextMenu2 自绘菜单都无法生效看来这就是IContextMenu3 出现的理由了所以我们跳过IContextMenu2 但还是要编写IContextMenu2 的方法即使是一个占位符在TYHContextMenu 的继承表中加入IContextMenu3 这里需要注意的一点是尽管IContextMenu3 是从IContextMenu 继承而来但并不意味着加入IContextMenu3 就可以去掉IContextMenu 否则的话

TYHContextMenu 就只支持IContextMenu3 而不支持IContextMenu 了从纯OOP 的角度来看似乎有点奇怪但必须记住这就是类继承和接口继承不同的地方因此在TYHContextMenu 的声明列表中必须同时有IContextMenu 和IContextMenu3

type

TYHContextMenu = class(TComObject, IShellExtInit, IContextMenu,

IContextMenu3)

protected

…

{ IContextMenu2 接口}

function HandleMenuMsg(uMsg: UINT; WParam, LParam: Integer): HResult;

stdcall;

{ IContextMenu3 接口}

function HandleMenuMsg2(uMsg: UINT; wParam, lParam: Integer;

var lpResult: Integer): HResult; stdcall;

end;

在IContextMenu::QueryContextMenu 方法的处理中如果选中的文件是图片文件的话

则要加入Owner-Draw 菜单

if IsImageFile(FFileList[0]) then begin // 图片文件

FGraphic := ImageFromFile(FFileList[0]);

if Assigned(FGraphic) then begin

InsertMenu(Menu, indexMenu+Added, mfSeparator, 0, nil);

InsertMenu(Menu, indexMenu+Added, mfOwnerDraw,

idCmdFirst+idImagePreview, nil);

InsertMenu(Menu, indexMenu+Added, mfSeparator, 0, nil);

// Inc(Added, 3);

end;

end;

其中用到两个辅助函数代码如下

function IsImageFile(const FileName: string): Boolean;

var

Ext : string;

begin

Ext := UpperCase(ExtractFileExt(FileName));

if (Ext='.ICO') or (Ext='.BMP') or (Ext='.EMF') or (Ext='.WMF') or (Ext='.JPG') or

(Ext='.JPEG') then

Result := True

else

Result := False;

end;

function ImageFromFile(const FileName: string): TGraphic;

var

Ext : string;

begin

Ext := UpperCase(ExtractFileExt(FileName));

Result := nil;

if (Ext<>'.ICO') and (Ext<>'.BMP') and (Ext<>'.BMP') and

(Ext<>'.WMF') and (Ext<>'.EMF') and (Ext<>'.JPG') and

(Ext<>'.JPEG') then begin

Result := nil;

Exit;

end;

try

if (Ext='.ICO') then

Result := TIcon.Create

else if (Ext='.BMP') then

Result := TBitmap.Create

else if (Ext='.EMF') or (Ext='.WMF') then

Result := TMetaFile.Create

else

Result := TJPEGImage.Create;

Result.LoadFromFile(FileName);

except

FreeAndNil(Result);

end;

end;

需要说明的是上述代码其实是比较笨拙的将图片文件的扩展名硬编码在程序中并不是一个很好的编程习惯我相信VCL 中应该有更灵活更具弹性的方法来实现类似的功能不过暂时我还没有找到更好的办法如果你有的话欢迎来信告诉我IContextMenu::InvokeCommand 的实现只要在Case 语句中增加一个分支即可

case LoWord(Integer(lpici.lpVerb)) of

…

idImagePreview:

ExecuteFile(lpici.hwnd, FFileList[0]);

end;

function ExecuteFile(Wnd: HWND; const FileName: string): THandle;

var

Path : string;

begin

Path := ExtractFilePath(FileName);

Result := ShellExecute(Wnd, 'open', PChar(FileName), nil, PChar(Path),

SW_SHOW);

end;

IContextMenu::GetCommandString 方法我就不在这里列出相信大家早就知道如何修改了接下来是IContextMenu2::HandleMenuMsg 我说过它只是个占位符

//=================================================

// IContextMenu2::HandleMenuMsg

//=================================================

function TYHContextMenu.HandleMenuMsg(uMsg: UINT; WParam,

LParam: Integer): HResult;

var

Ret : Integer;

begin

Ret := 0;

Result := HandleMenuMsg2(uMsg, wParam, lParam, Ret);

end;

IContextMenu2::HandleMenuMsg2 才是这里的重头戏对于Owner-Draw 菜单来说它需要处理两条消息WM_MEASUREITEM 和WM_DRAWITEM 由于这里只有一个Owner-Draw 菜单为了简便起见我也没有判断菜单的ID是否为idImagePreview

//=================================================

// IContextMenu::HandleMenuMsg2

//=================================================

function TYHContextMenu.HandleMenuMsg2(uMsg: UINT; wParam, lParam: Integer;

var lpResult: Integer): HResult;

var

pmis : PMeasureItemStruct;

pdis : PDrawItemStruct;

begin

Result := S_OK;

case uMsg of

WM_MEASUREITEM:

begin

pmis := PMeasureItemStruct(lParam);

if not Assigned(FGraphic) then begin

pmis.itemWidth := 120;

pmis.itemHeight := 120;

Exit;

end;

// 如果图片小于120*120 则按实际显示否则缩放到120*120

if (FGraphic.Width<=120) and (FGraphic.Height<=120) then begin

pmis.itemWidth := 140;

pmis.itemHeight := FGraphic.Height + 40;

end

else begin

pmis.itemWidth := 140;

pmis.itemHeight := 160;

end;

end;

WM_DRAWITEM:

begin

pdis := PDrawItemStruct(lParam);

DrawGraphic(pdis.hDC, pdis.rcItem, pdis.itemState, FGraphic);

end;

end;

end;

这里用到另外一个辅助函数DrawGraphic 它根据图形的大小决定调用TCanvas::Draw 还是TCanvas::StretchDraw 需要说明的是为了显示一个TGraphic 对象我们需要TCanvas作为它的绘制表面而系统传给我们的却是一个HDC 这里就需要一点技巧了把HDC 赋给TCanvas.Handle 是可行的不过千万要注意保存和恢复原始DC 的状态SaveDC/RestoreDC 否则后面的菜单很可能显示不正常这一段代码虽然比较长但是原理很简单前面的都是一些边界计算真正绘图的只有Draw/StretchDraw 一句

procedure DrawGraphic(adc: HDC; rc: TRect; State:Integer; Graphic: TGraphic);

var

rcImage, rcText, rcStretch : TRect;

Canvas : TCanvas;

nSaveDC : integer;

x, y : integer;

xScale, yScale, Scale : Double;

xStretch, yStretch : integer;

begin

with rcImage do begin

Left := rc.Left + 10;

Right := rc.Right - 10;

Top := rc.Top + 10;

Bottom := rc.Bottom - 30;

end;

with rcText do begin

Left := rc.Left + 10;

Right := rc.Right - 10;

Top := rc.Bottom - 20;

Bottom := rc.Bottom;

end;

Canvas := TCanvas.Create;

nSaveDC := 0;

try

nSaveDC := SaveDC(adc);

Canvas.Handle := adc;

with Canvas do begin

if not Assigned(Graphic) then begin

Rectangle(rcImage);

MoveTo(rcImage.Left, rcImage.Top);

LineTo(rcImage.Right, rcImage.Bottom);

MoveTo(rcImage.Right, rcImage.Top);

LineTo(rcImage.Left, rcImage.Bottom);

DrawText(Canvas.Handle, '未知图像', -1, rcImage,

DT_SINGLELINE or DT_CENTER or DT_VCENTER);

end

else begin

if (Graphic.Width<rcImage.Right-rcImage.Left) and

(Graphic.Height<rcImage.Bottom-rcImage.Top) then begin

x := rcImage.Left + (rcImage.Right - rcImage.Left - Graphic.Width) div

2;

y := rcImage.Top + (rcImage.Bottom - rcImage.Top - Graphic.Height)

div 2;

Canvas.Draw(x, y, Graphic);

end

else begin

xScale := Graphic.Width / (rcImage.Right-rcImage.Left);

yScale := Graphic.Height / (rcImage.Bottom-rcImage.Top);

Scale := Max(xScale, yScale);

xStretch := Trunc(Graphic.Width / Scale);

yStretch := Trunc(Graphic.Height / Scale);

x := rcImage.Left + (rcImage.Right-rcImage.Left - xStretch) div 2;

y := rcImage.Top + (rcImage.Bottom-rcImage.Top - yStretch) div 2;

rcStretch := Rect(x, y, x+xStretch, y+yStretch);

Canvas.StretchDraw(rcStretch, Graphic);

end;

Windows.FillRect(Canvas.Handle, rcText,

GetSysColorBrush(COLOR_MENU));

SetTextColor(Canvas.Handle, GetSysColor(COLOR_MENUTEXT));

SetBkColor(Canvas.Handle, GetSysColor(COLOR_MENU));

DrawText(Canvas.Handle, PChar(ImageInfoToStr(Graphic)), -1, rcText,

DT_SINGLELINE or DT_CENTER or DT_VCENTER);

end;

end;

finally

Canvas.Handle := 0;

Canvas.Free;

RestoreDC(adc, nSaveDC);

end;

end;

function ImageInfoToStr(Graphic: TGraphic): string;

begin

Result := Format('%d * %d', [Graphic.Width, Graphic.Height]);

if Graphic is TIcon then

Result := Result + ' 图标';

if Graphic is TBitmap then begin

case TBitmap(Graphic).PixelFormat of

pfDevice: Result := Result + ' DDB';

pf1bit: Result := Result + ' 2 色';

pf4bit: Result := Result + ' 16 色';

pf8bit: Result := Result + ' 256 色';

pf15bit, pf16bit: Result := Result + '16 位色';

pf24bit: Result := Result + '24 位色';

pf32bit: Result := Result + '32 位色';

pfCustom: Result := Result + '自定义';

end;

Result := Result + '位图';

end;

if Graphic is TMetaFile then

Result := Result + Format('(%d*%d) 元文件',

[TMetaFile(Graphic).MMWidth div 100, TMetaFile(Graphic).MMHeight div

100]);

if Graphic is TJPEGImage then begin

case TJPEGImage(Graphic).PixelFormat of

jf24Bit: Result := Result + ' 24 位色JPEG';

jf8Bit: Result := Result + ' 8 位色JPEG';

end;

end;

end;