Delphi实现shell扩展

2016-08-22 10:16:04来源:http://brantc.blog.51cto.com/410705/116484作者:xkdcc人点击


转贴自网上余昊的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;
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。(其他名称也行,但是不要和项目中的文件重复)
Ø 从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 – 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;
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;

最新文章

123

最新摄影

微信扫一扫

第七城市微信公众平台