参考这段代码, D5开发者指南的
unit ContMain;
interface
uses Windows, ComObj, ShlObj, ActiveX;
type
TContextMenu = class(TComObject, IContextMenu, IShellExtInit)
private
FFileName: array[0..MAX_PATH] of char;
FMenuIdx: UINT;
protected
// IContextMenu methods
function QueryContextMenu(Menu: HMENU; indexMenu, idCmdFirst, idCmdLast,
uFlags: UINT): HResult; stdcall;
function InvokeCommand(var lpici: TCMInvokeCommandInfo): HResult; stdcall;
function GetCommandString(idCmd, uType: UINT; pwReserved: PUINT;
pszName: LPSTR; cchMax: UINT): HResult; stdcall;
// IShellExtInit method
function Initialize(pidlFolder: PItemIDList; lpdobj: IDataObject;
hKeyProgID: HKEY): HResult; reintroduce; stdcall;
end;
TContextMenuFactory = class(TComObjectFactory)
protected
function GetProgID: string; override;
procedure ApproveShellExtension(Register: Boolean; const ClsID: string);
virtual;
public
procedure UpdateRegistry(Register: Boolean); override;
end;
implementation
uses ComServ, SysUtils, ShellAPI, Registry;
procedure ExecutePackInfoApp(const FileName: string; ParentWnd: HWND);
const
SPackInfoApp = '%sPackInfo.exe';
SCmdLine = '"%s" %s';
SErrorStr = 'Failed to execute PackInfo:'#13#10#13#10;
var
PI: TProcessInformation;
SI: TStartupInfo;
ExeName, ExeCmdLine: string;
Buffer: array[0..MAX_PATH] of char;
begin
// Get directory of this DLL. Assume EXE being executed is in same dir.
GetModuleFileName(HInstance, Buffer, SizeOf(Buffer));
ExeName := Format(SPackInfoApp, [ExtractFilePath(Buffer)]);
ExeCmdLine := Format(SCmdLine, [ExeName, FileName]);
FillChar(SI, SizeOf(SI), 0);
SI.cb := SizeOf(SI);
if not CreateProcess(PChar(ExeName), PChar(ExeCmdLine), nil, nil, False,
0, nil, nil, SI, PI) then
MessageBox(ParentWnd, PChar(SErrorStr + SysErrorMessage(GetLastError)),
'Error', MB_OK or MB_ICONERROR);
end;
{ TContextMenu }
{ TContextMenu.IContextMenu }
function TContextMenu.QueryContextMenu(Menu: HMENU; indexMenu, idCmdFirst,
idCmdLast, uFlags: UINT): HResult;
begin
FMenuIdx := indexMenu;
// Add one menu item to context menu
InsertMenu (Menu, FMenuIdx, MF_STRING or MF_BYPOSITION, idCmdFirst,
'Package Info...');
// Return index of last inserted item + 1
Result := FMenuIdx + 1;
end;
function TContextMenu.InvokeCommand(var lpici: TCMInvokeCommandInfo): HResult;
begin
Result := S_OK;
try
// Make sure we are not being called by an application
if HiWord(Integer(lpici.lpVerb)) <> 0 then
begin
Result := E_FAIL;
Exit;
end;
// Execute the command specified by lpici.lpVerb.
// Return E_INVALIDARG if we are passed an invalid argument number.
if LoWord(lpici.lpVerb) = FMenuIdx then
ExecutePackInfoApp(FFileName, lpici.hwnd)
else
Result := E_INVALIDARG;
except
MessageBox(lpici.hwnd, 'Error obtaining package information.', 'Error',
MB_OK or MB_ICONERROR);
Result := E_FAIL;
end;
end;
function TContextMenu.GetCommandString(idCmd, uType: UINT; pwReserved: PUINT;
pszName: LPSTR; cchMax: UINT): HRESULT;
begin
Result := S_OK;
try
// make sure menu index is correct, and shell is asking for help string
if (idCmd = FMenuIdx) and ((uType and GCS_HELPTEXT) <> 0) then
// return help string for menu item
StrLCopy(pszName, 'Get information for the selected package.', cchMax)
else
Result := E_INVALIDARG;
except
Result := E_UNEXPECTED;
end;
end;
{ TContextMenu.IShellExtInit }
function TContextMenu.Initialize(pidlFolder: PItemIDList; lpdobj: IDataObject;
hKeyProgID: HKEY): HResult;
var
Medium: TStgMedium;
FE: TFormatEtc;
begin
try
// Fail the call if lpdobj is nil.
if lpdobj = nil then
begin
Result := E_FAIL;
Exit;
end;
with FE do
begin
cfFormat := CF_HDROP;
ptd := nil;
dwAspect := DVASPECT_CONTENT;
lindex := -1;
tymed := TYMED_HGLOBAL;
end;
// Render the data referenced by the IDataObject pointer to an HGLOBAL
// storage medium in CF_HDROP format.
Result := lpdobj.GetData(FE, Medium);
if Failed(Result) then Exit;
try
// If only one file is selected, retrieve the file name and store it in
// szFile. Otherwise fail the call.
if DragQueryFile(Medium.hGlobal, $FFFFFFFF, nil, 0) = 1 then
begin
DragQueryFile(Medium.hGlobal, 0, FFileName, SizeOf(FFileName));
Result := NOERROR;
end
else
Result := E_FAIL;
finally
ReleaseStgMedium(medium);
end;
except
Result := E_UNEXPECTED;
end;
end;
{ TContextMenuFactory }
function TContextMenuFactory.GetProgID: string;
begin
// ProgID not required for context menu shell extension
Result := '';
end;
procedure TContextMenuFactory.UpdateRegistry(Register: Boolean);
var
ClsID: string;
begin
ClsID := GUIDToString(ClassID);
inherited UpdateRegistry(Register);
ApproveShellExtension(Register, ClsID);
if Register then
begin
// must register .bpl as a file type
CreateRegKey('.bpl', '', 'BorlandPackageLibrary');
// register this DLL as a context menu handler for .bpl files
CreateRegKey('BorlandPackageLibrary/shellex/ContextMenuHandlers/' +
ClassName, '', ClsID);
end
else begin
DeleteRegKey('.bpl');
DeleteRegKey('BorlandPackageLibrary/shellex/ContextMenuHandlers/' +
ClassName);
end;
end;
procedure TContextMenuFactory.ApproveShellExtension(Register: Boolean;
const ClsID: string);
// This registry entry is required in order for the extension to
// operate correctly under Windows NT.
const
SApproveKey = 'SOFTWARE/Microsoft/Windows/CurrentVersion/Shell Extensions/Approved';
begin
with TRegistry.Create do
try
RootKey := HKEY_LOCAL_MACHINE;
if not OpenKey(SApproveKey, True) then Exit;
if Register then WriteString(ClsID, Description)
else DeleteValue(ClsID);
finally
Free;
end;
end;
const
CLSID_CopyHook: TGUID = '{7C5E74A0-D5E0-11D0-A9BF-E886A83B9BE5}';
initialization
TContextMenuFactory.Create(ComServer, TContextMenu, CLSID_CopyHook,
'D4DG_ContextMenu', 'D4DG Context Menu Shell Extension Example',
ciMultiInstance, tmApartment);
end.
