.各位，我在调试《Delphi6开发人员指南》中16章中的环境菜单处理器时，出现一个错误提示：c:\winnt\explorer.exe找不到的错误，显然，
这个程序实在win2000下面写的，可是如何把代码改变一下，使他适应不同
的windows下运行呢，特别是windowxP下面。：一下是书上自带的源代码：
：
库文件（dll）代码：
library ContMenu;uses
ComServ,
ContMain in 'ContMain.pas';exports
DllGetClassObject,
DllCanUnloadNow,
DllRegisterServer,
DllUnregisterServer;begin
end.
Dll中使用到的ContMain单元，代码：
unit ContMain;interfaceuses 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;implementationuses ComServ, SysUtils, ShellAPI, Registry, Math;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;
const
SCmdStrA: String = 'Get information for the selected package.';
SCmdStrW: WideString = 'Get information for the selected package.';
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
begin
// return help string for menu item
if Win32MajorVersion >= 5 then // treat as unicode for Win2k or higher
Move(SCmdStrW[1], pszName^,
Min(cchMax, Length(SCmdStrW) + 1) * SizeOf(WideChar))
else
// tread as ANSI otherwise
StrLCopy(pszName, PChar(SCmdStrA), Min(cchMax, Length(SCmdStrA) + 1));
end
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);
if (win32platform = ver_platform_win32_nt) then
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,
'DDG_ContextMenu', 'DDG Context Menu Shell Extension Example',
ciMultiInstance, tmApartment);
end.
这个程序实在win2000下面写的，可是如何把代码改变一下，使他适应不同
的windows下运行呢，特别是windowxP下面。：一下是书上自带的源代码：
：
库文件（dll）代码：
library ContMenu;uses
ComServ,
ContMain in 'ContMain.pas';exports
DllGetClassObject,
DllCanUnloadNow,
DllRegisterServer,
DllUnregisterServer;begin
end.
Dll中使用到的ContMain单元，代码：
unit ContMain;interfaceuses 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;implementationuses ComServ, SysUtils, ShellAPI, Registry, Math;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;
const
SCmdStrA: String = 'Get information for the selected package.';
SCmdStrW: WideString = 'Get information for the selected package.';
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
begin
// return help string for menu item
if Win32MajorVersion >= 5 then // treat as unicode for Win2k or higher
Move(SCmdStrW[1], pszName^,
Min(cchMax, Length(SCmdStrW) + 1) * SizeOf(WideChar))
else
// tread as ANSI otherwise
StrLCopy(pszName, PChar(SCmdStrA), Min(cchMax, Length(SCmdStrA) + 1));
end
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);
if (win32platform = ver_platform_win32_nt) then
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,
'DDG_ContextMenu', 'DDG Context Menu Shell Extension Example',
ciMultiInstance, tmApartment);
end.
解决方案 »
免费领取超大流量手机卡，每月29元包185G流量+100分钟通话, 中国电信官方发货