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 ,所以,这里是初始化的最好地方。
 
 

6. 实现InitializeDestroyIShellExtInit.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 �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;
 
 

你可能感兴趣的:(shell,职场,Delphi,休闲)