Delphi实现shell扩展
转贴自网上余昊 的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 ，所以，这里是初始化的最好地方。
因为 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;
end;
|
TfrmCopyAnywhere
是界面，使用
SHFileOperation
来执行
Copies, moves, renames, or deletes a file system object
，据说好用。
OK
，接下来实现第三个函数，也是这个接口的最后一个函数：
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;
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;
end;
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;
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 。（其他名称也行，但是不要和项目中的文件重复）
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;
end;
WM_DRAWITEM:
begin
pdis := PDrawItemStruct(lParam);
DrawGraphic(pdis.hDC, pdis,rcItem, pdis.itemState, FGraphic);
end;
end;
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 �C 10;
Top := rc.Top + 10;
Bottom := rc.Bottom �C 30;
end;
with rcText do
begin
Left := rc.Left + 10;
Right := rc.Right �C 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;
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
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;
end;
end;
|