Delphi编写Shell扩展

用delphi创建一个外壳扩展(Shell Extension)程序的基本步骤如下：

(1) 创建一个 ActiveX Library 工程，命名为“CloudUpload“
(2) 创建一个新的自动化对象（Automation Object）。 命名为“ TCloudUploadContext ”

TCloudUploadContext 类必须实现两个接口即：IShellExtInit 和 IContextMenu，
这样就可以在Windows Explorer 中集成该上下文菜单（Context Menu）。

{ IShellExtInit Methods }
{ Initialize the context menu if a files was selected}
function IShellExtInit.Initialize = ShellExtInitialize;
function ShellExtInitialize(pidlFolder: PItemIDList; lpdobj: IDataObject;
hKeyProgID: HKEY): HResult; stdcall;

{ IContextMenu Methods }
{ Initializes the context menu and it decides which items appear in it,
based on the flags you pass }
function QueryContextMenu(Menu: HMENU; indexMenu, idCmdFirst, idCmdLast,
uFlags: UINT): HResult; stdcall;

{ Execute the command, which will be the upload to Amazon or Azure}
function InvokeCommand(var lpici: TCMInvokeCommandInfo): HResult; stdcall;
{ Set help string on the Explorer status bar when the menu item is selected }
function GetCommandString(idCmd: UINT_PTR; uFlags: UINT; pwReserved: PUINT;
pszName: LPSTR; cchMax: UINT): HResult; stdcall;

ShellExtInitialize 定义了是否在 Windows Explorer 中显示上下文菜单（Context Menu）。
在该例子中，上下文菜单（Context Menu）仅当一个文件被选中的时候才显示出来，否则不会显示。
在一文件被选中时， FFileName 变量将接收该文件的文件名。

function TCloudUploadContextMenu.ShellExtInitialize(pidlFolder: PItemIDList;
lpdobj: IDataObject; hKeyProgID: HKEY): HResult;
var
DataFormat: TFormatEtc;
StrgMedium: TStgMedium;
Buffer: array [0 .. MAX_PATH] of Char;
begin
Result := E_FAIL;

{ Check if an object was defined }
if lpdobj = nil then
Exit;

{ Prepare to get information about the object }
DataFormat.cfFormat := CF_HDROP;
DataFormat.ptd := nil;
DataFormat.dwAspect := DVASPECT_CONTENT;
DataFormat.lindex := -1;
DataFormat.tymed := TYMED_HGLOBAL;

if lpdobj.GetData(DataFormat, StrgMedium) <> S_OK then
Exit;

{ The implementation now support only one file }
if DragQueryFile(StrgMedium.hGlobal, $FFFFFFFF, nil, 0) = 1 then
begin
SetLength(FFileName, MAX_PATH);
DragQueryFile(StrgMedium.hGlobal, 0, @Buffer, SizeOf(Buffer));
FFileName := Buffer;
Result := NOERROR;
end
else
begin
// Don't show the Menu if more then one file was selected
FFileName := EmptyStr;
Result := E_FAIL;
end;

{ http://msdn.microsoft.com/en-us/library/ms693491(v=vs.85).aspx }
ReleaseStgMedium(StrgMedium);

end;

在上下文件菜单句柄（context menu handler）在IShellExtInit接口中被初始化之后，
Windows系统使用 IContextMenu 接口去调用(call)上下文件菜单句柄中的其他方法。
在这种情形下，它将调用(call) QueryContextMenu, GetCommandString 和 InvokeCommand。

上下文件菜单选项（包括 Amazon S3 和 Microsoft Azure ）将通过 QueryContextMenu 方法被创建。

function TCloudUploadContextMenu.QueryContextMenu(Menu: HMENU;
indexMenu, idCmdFirst, idCmdLast, uFlags: UINT): HResult;
var
CloudMenuItem: TMenuItemInfo;
MenuCaption: String;
SubMenu: HMENU;
uId: UINT;
begin
{ only adding one menu CloudMenuItem, so generate the result code accordingly }
Result := MakeResult(SEVERITY_SUCCESS, 0, 3);

{ store the menu CloudMenuItem index }
FMenuItemIndex := indexMenu;

{ specify what the menu says, depending on where it was spawned }
if (uFlags = CMF_NORMAL) then // from the desktop
MenuCaption := 'Send file from Desktop to the Cloud'
else if (uFlags and CMF_VERBSONLY) = CMF_VERBSONLY then // from a shortcut
MenuCaption := 'Send file from Shourtcut to the Cloud'
else if (uFlags and CMF_EXPLORE) = CMF_EXPLORE then // from explorer
MenuCaption := 'Send file from Explorer to the Cloud'
else
{ fail for any other value }
Result := E_FAIL;

if Result <> E_FAIL then
begin

SubMenu := CreatePopupMenu;

uId := idCmdFirst;
InsertMenu(SubMenu, AmazonIndex, MF_BYPOSITION, uId, TClouds[AmazonIndex]);

Inc(uId);
InsertMenu(SubMenu, AzureIndex, MF_BYPOSITION, uId, TClouds[AzureIndex]);

FillChar(CloudMenuItem, SizeOf(TMenuItemInfo), #0);
CloudMenuItem.cbSize := SizeOf(TMenuItemInfo);
CloudMenuItem.fMask := MIIM_SUBMENU or MIIM_STRING or MIIM_ID;
CloudMenuItem.fType := MFT_STRING;
CloudMenuItem.wID := FMenuItemIndex;
CloudMenuItem.hSubMenu := SubMenu;
CloudMenuItem.dwTypeData := PWideChar(MenuCaption);
CloudMenuItem.cch := Length(MenuCaption);

InsertMenuItem(Menu, indexMenu, True, CloudMenuItem);
end;
end;

在 Windows Explorer 中你用鼠标滑过该云菜单项（Cloud menu items ）时会在状态栏中显示出瞬时帮助（提示）信息。 这个提示信息定义并在GetCommandString 方法中实现。

function TCloudUploadContextMenu.GetCommandString(idCmd: UINT_PTR; uFlags: UINT;

pwReserved: PUINT; pszName: LPSTR; cchMax: UINT): HResult;
begin
Result := E_INVALIDARG;

{ Set help string on the Explorer status bar when the menu item is selected }
if (idCmd in [AmazonIndex, AzureIndex]) and (uFlags = GCS_HELPTEXT) then
begin
StrLCopy(PWideChar(pszName), PWideChar('Copy the selected file to ' +
TClouds[idCmd]), cchMax);
Result := NOERROR;
end;

end;

当用户点击了一个云菜单项（Cloud menu items）中某一项时，InvokeCommand 方法将被调用（call）并且启动一个上传被选中的文件到目标云（Cloud）上的进程。
这样，我们就已经有了该文件名，基于 lpici 这个参数，我们能够分辨用户点击了哪个菜单项。

function TCloudUploadContextMenu.InvokeCommand(var lpici: TCMInvokeCommandInfo): HResult;
var
Item: Word;
begin
Result := E_FAIL;

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

{ if the index matches the index for the menu, show the cloud options }
Item := LoWord(Integer(lpici.lpVerb));

if Item in [AmazonIndex, AzureIndex] then
begin
try
Upload(lpici.HWND, Item, FFileName);
except
on E: Exception do
MessageBox(lpici.hwnd, PWideChar(E.Message), 'Cloud Upload', MB_ICONERROR);

end;
Result := NOERROR;
end;

end;

为确保当 CloudUpload 被加载时，该 COM对象（COM object）被创建，有必要创建一个类工厂的一个实例，特别是要创建一个该外壳扩展对象（the shell extension object）的一个实例，该工厂实例将在 initialization代码段中被创建。

initialization
TCloudUploadObjectFactory.Create(ComServer, TCloudUploadContextMenu, CLASS_CloudUploadContextMenu, ciMultiInstance, tmApartment);
end.

由于该类工厂将负责注册或反注册该DLL，当你使用 regsvr32.exe 的时候，ApproveShellExtension 和 UpdateRegistry 两个方法将被调用（invoked)。

注册 CloudUpload 外壳扩展应用
以管理员身份运行cmd

注册命令：
regsvr32 <PATH WHERE IS LOCATED THE DLL>CloudUpload.dll

反注册命令：
regsvr32 <PATH WHERE IS LOCATED THE DLL>CloudUpload.dll /u

原文地址：http://www.andreanolanusse.com/en/shell-extension-for-windows-32-bit-and-64-bit-with-delphi-xe2/