Delphi实现shell扩展-白红宇

本文转自 xkdcc 51CTO博客，原文链接：http://blog.51cto.com/brantc/116484，如需转载请自行联系原作者

转贴自网上余昊的pdf格式，经过自己的整理，放于此共享。本博客转贴文章无意侵犯版权，如有，请先通知，本博客会即刻处理

1. 准备工作

1．

对注册表做一些工作。因为任何外壳扩展都是作为DLL

加载到Explorer

的进程空间的，如果不做手脚，那么，只要Explorer

存在，那么你就无法顺利编译shell

程序。建议使用Windows

优化大师，选中“启动系统时为桌面和Explorer

创建独立的进程”

2．

下载DebugView

来调试外壳扩展程序。

3．

一定要处理你能够处理的所有错误。因为，你知道，Explorer

在Windows

中的重要性，你稍不留神就崩掉的话，恐怕没人敢用你的外壳程序了:)

2. 需求

1．

对任何文件可以进行Copy(Move) to Anywhere

。参考软件Nuts & Bolt

。

2．

对于COM

组件库，能够实现Register/Unregister

功能。

3．

对于图片文件，能在Context Menu

中预览。参考软件PicaView

。

3. 搭建框架

因为任何外壳扩展都是COM

组件，所以，需要建立一个ActiveX Library

，以及一个COM Object

。另外，外壳扩展需要对Delphi

生成的代码进行额外处理才能成为一个外壳扩展COM

组件，即从

TComObjectFactory

派生一个类才行。

4. 接口支持需求

绝大多数外壳程序需要支持基本的接口：

IShellExtInit

另外，对于每一种扩展，我们还需要实现一到两个接口。

对于Context Menu

，必须支持的两个接口是：

IShellExtInit

和 IContextMenu

如果要支持自绘式菜单，还需要支持的接口：

IContextMenu2

或者 IContextMenu3

5. 解决继承接口的命名冲突

示例代码：使用语法解决继承接口的命名冲突

TCCContextMenu = class(TComObject, IShellExtInit)

private

FFileList: TStringList;

FGraphic: TGraphic;

protected

{ IShellExtInit

接口 }

function IShellExtInit.Initialize = SEInitialize;

function SEInitialize(pidFolder: PItemIDList; lpdobj: IDataObject; hKeyProgID: HKEY): HResult; stdcall;

public

procedure Initialize; override;

destructor Destroy; override;

代码分析：

1）

为什么重载了TComObj

的Initialize

和Destroy

而不是Create

？

因为TComObj

有多个构造函数，但是无论哪个，都会调用Initialize

，所以，这里是初始化的最好地方。

6. 实现Initialize、Destroy和IShellExtInit.Initialize

Initialize

和Destroy

很简单，可以加入打印的调试信息，便于观察外壳扩展的生命周期；主要是实现IShellExtInit.Initialize

。

IShellExtInit.Initialize

的三个参数中，最重要的是系统传递给我们的IDataObject

，我们可以从中获得用户选择的文件列表。

示例代码：IShellExtInit.Initialize.

可以被任何实现IShellExtInit

的类所调用

function TCCContextMenu.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;

7. 实现对IContextMenu的支持

IContextMenu

有三个方法，首先讲菜单弹出前系统调用的方法：

QueryContextMenu

function QueryContextMenu(Menu: HMENU; indexMenu, idCmdFirst, idCmdLast, uFlags: UINT): HRESULT; stdcall;

Ø Menu:

就是系统开发给你的上下文菜单的句柄，可以用InsertMenu

或者InsertMenuItem

之类的函数向里面增加菜单

Ø indexMenu:

系统预留给你的菜单项的位置，你应该从这个位置开始加入菜单，但是加入的菜单项个数不要超过idCmdLast-idCmdFirst

这个范围

Ø uFlags:

是一些标志位。

返回值：函数的返回值应该是你加入的菜单个数和其他一些标志的组合。

示例代码： QueryContextMenu

const

菜单类型

mfString = MF_STRING or MF_BYPOSITION;

mfOwnerDraw = MF_OWNERDRAW or MF_BYPOSITION;

mfSeparator = MF_SEPARATOR or MF_BYPOSITION;

菜单项

idCopyAnywhere = 0; //

复制（移动）

idRegister = 5; //

注册ActiveX

idUnregister = 6; //

取消注册ActiveX

idImagePreview = 10; //

预览图片文件

idMenuRange = 90;

在SDK

中是使用宏Make_HRESULT

实现的，Delphi

没有宏的概念，所以这里用函数

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

begin

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

end;

function TCCContextMenu.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;

接下来实现第二个函数：

InvokeCommand

这是在用户点击菜单时调用，是真正执行动作的地方。

示例代码： InvokeCommand

function TCCContextMenu.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);

end;

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;

TfrmCopyAnywhere

是界面，使用SHFileOperation

来执行Copies, moves, renames, or deletes a file system object

，据说好用。

，接下来实现第三个函数，也是这个接口的最后一个函数：

GetCommandString

当用户选择菜单项时，在资源管理器的状态栏会显示一些提示信息，这里需要注意Unicode/Ansi

的区别。

示例代码： GetCommandString

function TCCContextMenu.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 //Anse

begin

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

end

else

begin

wstrTip := strTip;

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

end;

Result := S_OK;

end;

8. 实现Context Menu Extension的类工厂

如果没有实现Context Menu Extension

的类工厂，那么期待已久的shell

扩展还是没法实现:)

这里需要处理很多注册表，幸好Delphi

有几个好函数，所以可以省很多功夫。

示例代码：实现Context Menu Extension

的类工厂

procedure TCCContextMenuFactory.UpdateRegistry(Register: Boolean);

procedure DeleteRegValue(const Path, ValueName: String; Root: DWord=HKEY_CLASSES_ROOT);

var

reg: TRegistry;

begin

reg := TRegistry.Create;

with reg do

begin

try

RootKey := Root;

if OpenKey(Path, False) then

begin

if ValueExists(ValueName) then DeleteValue(ValueName);

CloseKey;

end;

finally

Free;

end;

const

RegPath = ‘*\shellex\ContextMenuHandlers\CCShellExt’;

ApprovedPath = ‘Software\Microsoft\Windows\CurrentVersion\ShellExtensions\Approved’;

var

strGUID: String;

begin

inherited;

strGUID := GUIDToString(Class_CCContextMenu);

if Register then

begin

CreateRegKey(RegPath, ‘‘, strGUID);

CreateRegKey(ApprovedPath, strGUID, ‘CC

的外壳扩展’, HKEY_LOCAL_MACHINE);

end

else

begin

DeleteRegKey(RegPath);

DeleteRegValue(ApprovedPath, strGUID, HKEY_LOCAL_MACHINE);

end;

现在，在添加新的全局对象初始化：

示例代码：

initialization

TCCContextMenuFactory.Create(ComServer, TCCContextMenu, Class_CCContextMenu, '', '', ciMultiInstance, tmApartment);

TTypedComObjectFactory.Create(ComServer, TCCContextMenu, Class_CCContextMenu,

ciMultiInstance, tmApartment);

然后，只要在IDE

中执行Run->Register ActiveX Server

命令，就可以在资源管理器中检阅自己的劳动成果了:)

9. 实现ActiveX的注册/反注册功能

我们这里还实现了从菜单对选择的单一exe/ocx

文件进行注册的功能。这主要就是载入ActiveX

库，然后调用DllRegisterServer

或者DllUnregisterServer

。这样，需要修改原来实现的接口的代码。

同时，这里为注册和反注册菜单加入了两个图标，使用SetMenuItemBitmaps

函数实现。

先讲一下，如何在Delphi

中加入资源：

准备两个14*14

的图像（如果不嫌麻烦的话，可以用GetMenuCheckMarkDimensions

确认下是否为这个大小）

建立一个文本文件，写入：

101 BITMAP

“reg.bmp

”

102 BITMAP

“unreg.bmp

”

然后保存为ExtraRes.rc

。（其他名称也行，但是不要和项目中的文件重复）

从IDE

中选择菜单Add to Project

，选择即可。

主要代码如下：

示例代码：

实现注册/

反注册功能。4

个方法：IsActiveLib

，RegisterActiveLib

，UnregisterActiveLib

，ReportWin32Error

resourcestring

sCopyAnywhere = ‘

复制到... ‘;

sCopyAnywhereTip = ‘

将选定的文件复制到任何路径下’;

sRegister = ‘

注册...’;

sRegisterTip = ‘

注册ActiveX

库’;

sUnregister = ‘

取消注册...’;

sUnregisterTip = ‘

取消注册ActiveX

库’;

sImagePreview = ‘

预览图片文件’;

sImagePreviewTip = ‘

预览图片文件’;

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 : TDllRegisterServer;

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;

prcedure ReportWin32Error(Wnd: HWND; const Prefix: String; dwError: DWord);

var

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

str: String;

begin

FormatMessage(FROMAT_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;

10. 加入图像预览功能

IContextMenu

虽然能支持普通的菜单项，但是无法处理自绘制的菜单（Owner-Draw

）。即使用MF_OWNERDRAW

加入菜单也不行，因为自绘制菜单的处理，最终要由Exploer

的窗口进行，而IContextMenu

没有提供一条截获窗口过程对菜单的处理。微软然后加入了IContextMenu2

和IContextMenu2

，但是IContextMenu2

好像还是没有起作用，所以，我们用IContextMenu3

来实现。

主要代码如下：

示例代码：IContextMenu3.HandleMenuMsg2

function TCCContextMenu.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;

WM_DRAWITEM:

begin

pdis := PDrawItemStruct(lParam);

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

end;

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.Top - 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_VECNTER);

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, GetSysColor(COLOR_MENUTEXT));

SetBkColor(Canvas. Handle, PChar(ImageInfoToStr(Graphic)), -1, rcText, DT_SINGLELINE or DT_CENTER or DT_VCENTER);

end;

finally

Canvas.Handle :=0;

Canvas.Free;

RestoreDC(adc, nSaveDC);

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

begin

Result := Result + Format(‘(%d*%d)

元文件’, [TMetaFile(Graphic),MMWidth div 100, TMetaFile(Graphic).MMHeight div 100])

end;

if Graphic is TJPEGImage then

begin

case TJPEGImage(Graphic).PixelFormat of

jf24Bit: Result := Result + ‘24

位色JPEG’;

jf8Bit: Result := Result + ‘8

位色JPEG’;

end;