[求助]上下文相关菜单（shell扩展编程）.没分了，请大家原谅 ( 积分: 0 )

  • 主题发起人 主题发起人 涅磐的凤凰
  • 开始时间 开始时间
涅

涅磐的凤凰

Unregistered / Unconfirmed
GUEST, unregistred user!
程序的功能类似winzip，右键弹出上下文相关菜单。源代码是照着Demos/ActiveX/ShellExt里面的contmenu.dpr改的，
我对COM和注册表不熟悉，一时找不到错误。

如果哪位有空请帮忙看看，代码比较长，如果阁下没空就不用往下看了. 谢谢













功能说明：我需要用 datalab.exe(公司自己开发的软件) 打开特定类型的文件，特定类型的文件后缀名为 ".001"
我已经在程序里面把 *.001关联到datalab.exe了
现在我需要用右键点击 *.001 文件时，弹出 "用datalab打开&quot
的字样


问题:
下面是完整的程序清单，可以编译通过，并顺利注册生成的DLL文件。就是在右键菜单里面显示不出"用datalab打开&quot
的字样。
不知道是程序有误还是我操作上有不对的地方.






我建立了一个 Active X Library 工程，工程文件为 contmenuDataLab.dpr，又新建了一个ContextData.pas的Unit

contmenuDataLab.dpr程序清单如下：


library contmenuDataLab;

uses
ComServ,
ContextData in 'ContextData.pas';

exports
DllGetClassObject,
DllCanUnloadNow,
DllRegisterServer,
DllUnregisterServer;

begin
end.


ContextData程序清单如下:

unit ContextData;

interface

uses
Windows, ActiveX, ComObj, ShlObj, Dialogs;

type
TContextMenu = class(TComObject, IShellExtInit, IContextMenu)
private
FFileName: array[0..MAX_PATH] of Char;
protected
{ IShellExtInit }
function IShellExtInit.Initialize = SEIInitialize

function SEIInitialize(pidlFolder: PItemIDList
lpdobj: IDataObject;
hKeyProgID: HKEY): HResult
stdcall;
{ IContextMenu }
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;
end;

const
Class_ContextMenu: TGUID = '{45DEFB54-6F67-4997-B87C-D833CD6A01E0}';

implementation

uses ComServ, SysUtils, ShellApi, Registry;

function TContextMenu.SEIInitialize(pidlFolder: PItemIDList
lpdobj: IDataObject;
hKeyProgID: HKEY): HResult;
var
StgMedium: TStgMedium;
FormatEtc: TFormatEtc;
begin
//如果lpdobj等于Nil，则本调用失败
if (lpdobj = nil) then begin
Result := E_INVALIDARG;
Exit;
end;
//初始化剪贴板格式文件
with FormatEtc do begin
cfFormat := CF_HDROP;
ptd := nil;
dwAspect := DVASPECT_CONTENT;
lindex := -1;
tymed := TYMED_HGLOBAL;
end;

Result := lpdobj.GetData(FormatEtc, StgMedium);
if Failed(Result) then
Exit;
// If only one file is selected, retrieve the file name and store it in
// FFileName. Otherwise fail the call.
//如果选中了一个文件，将文件名存储到FFileName，否则本调用失败
if (DragQueryFile(StgMedium.hGlobal, $FFFFFFFF, nil, 0) = 1) then begin
DragQueryFile(StgMedium.hGlobal, 0, FFileName, SizeOf(FFileName));
Result := NOERROR;
end
else begin
FFileName[0] := #0;
Result := E_FAIL;
end;
ReleaseStgMedium(StgMedium);
end;

function TContextMenu.QueryContextMenu(Menu: HMENU
indexMenu, idCmdFirst,
idCmdLast, uFlags: UINT): HResult;
begin
Result := 0
// or use MakeResult(SEVERITY_SUCCESS, FACILITY_NULL, 0);

if ((uFlags and $0000000F) = CMF_NORMAL) or
((uFlags and CMF_EXPLORE) <> 0) then begin
//往 context menu 中加入一个菜单项
InsertMenu(Menu, indexMenu, MF_STRING or MF_BYPOSITION, idCmdFirst,
'打开此数据文件');

// Return number of menu items added
Result := 1
// or use MakeResult(SEVERITY_SUCCESS, FACILITY_NULL, 1)
end;
end;

function GetCompilerPath: string;
//返回 datalab.exe的路径
var
Reg: TRegistry;
begin
Reg := TRegistry.Create;
try
with Reg do begin
RootKey := HKEY_LOCAL_MACHINE;

OpenKey('/SOFTWARE/Hotinst/DataLab', False);
Result := ExpandFileName(ReadString('RootDir') + '/DataLab.exe');
end;
if AnsiPos(' ', Result) <> 0 then
Result := ExtractShortPathName(Result);
Result := Result + ' &quot;%s&quot;';
finally
Reg.Free;
end;
end;

function TContextMenu.InvokeCommand(var lpici: TCMInvokeCommandInfo): HResult;
resourcestring
sPathError = 'Error setting current directory';

var
H: THandle;
PrevDir: string;

begin
Result := E_FAIL;
//确定该过程是被系统而不是被一个程序所调用
if (HiWord(Integer(lpici.lpVerb)) <> 0) then
begin
Exit;
end;

// Make sure we aren't being passed an invalid argument number
//确定传递的参数的有效性
if (LoWord(lpici.lpVerb) <> 0) then begin
Result := E_INVALIDARG;
Exit;
end;


//用datalab.exe从lpici.lpVerb中调用文件
PrevDir := GetCurrentDir;
try
if not SetCurrentDir(ExtractFilePath(FFileName)) then
raise Exception.CreateRes(@sPathError);

H := WinExec(PChar(Format(GetCompilerPath, [FFileName])), lpici.nShow);

if (H < 32) then
MessageBox(lpici.hWnd, 'Error executing DataLab.exe .', 'Error',
MB_ICONERROR or MB_OK);
Result := NOERROR;
finally
SetCurrentDir(PrevDir);
end;
end;

function TContextMenu.GetCommandString(idCmd, uType: UINT
pwReserved: PUINT;
pszName: LPSTR
cchMax: UINT): HRESULT;
begin
if (idCmd = 0) then begin
if (uType = GCS_HELPTEXT) then

//从菜单项返回帮助字符
StrCopy(pszName, '用DataLab打开此数据文件');
Result := NOERROR;
end
else
Result := E_INVALIDARG;
end;

type
TContextMenuFactory = class(TComObjectFactory)
public
procedure UpdateRegistry(Register: Boolean)
override;
end;

procedure TContextMenuFactory.UpdateRegistry(Register: Boolean);
var
ClassID: string;
begin
if Register then begin
inherited UpdateRegistry(Register);

ClassID := GUIDToString(Class_ContextMenu);
CreateRegKey('DataLab/shellex', '', '');
CreateRegKey('DataLab/shellex/ContextMenuHandlers', '', '');
CreateRegKey('DataLab/shellex/ContextMenuHandlers/ContMenu', '', ClassID);

if (Win32Platform = VER_PLATFORM_WIN32_NT) then
with TRegistry.Create do
try
RootKey := HKEY_LOCAL_MACHINE;
OpenKey('SOFTWARE/Microsoft/Windows/CurrentVersion/Shell Extensions', True);
OpenKey('Approved', True);
WriteString(ClassID, 'DataLab Context Menu Shell Extension');
finally
Free;
end;
end
else begin
DeleteRegKey('DataLab/shellex/ContextMenuHandlers/ContMenu');
DeleteRegKey('DataLab/shellex/ContextMenuHandlers');
DeleteRegKey('DataLab/shellex')

inherited UpdateRegistry(Register);
end;
end;

initialization
TContextMenuFactory.Create(ComServer, TContextMenu, Class_ContextMenu,
'', 'DataLab Context Menu Shell Extension', ciMultiInstance,
tmApartment);
end.
 
程序的功能类似winzip，右键弹出上下文相关菜单。源代码是照着Demos/ActiveX/ShellExt里面的contmenu.dpr改的，
我对COM和注册表不熟悉，一时找不到错误。

如果哪位有空请帮忙看看，代码比较长，如果阁下没空就不用往下看了. 谢谢













功能说明：我需要用 datalab.exe(公司自己开发的软件) 打开特定类型的文件，特定类型的文件后缀名为 &quot;.001&quot;
我已经在程序里面把 *.001关联到datalab.exe了
现在我需要用右键点击 *.001 文件时，弹出 &quot;用datalab打开&quot
的字样


问题:
下面是完整的程序清单，可以编译通过，并顺利注册生成的DLL文件。就是在右键菜单里面显示不出&quot;用datalab打开&quot
的字样。
不知道是程序有误还是我操作上有不对的地方.






我建立了一个 Active X Library 工程，工程文件为 contmenuDataLab.dpr，又新建了一个ContextData.pas的Unit

contmenuDataLab.dpr程序清单如下：


library contmenuDataLab;

uses
ComServ,
ContextData in 'ContextData.pas';

exports
DllGetClassObject,
DllCanUnloadNow,
DllRegisterServer,
DllUnregisterServer;

begin
end.


ContextData程序清单如下:

unit ContextData;

interface

uses
Windows, ActiveX, ComObj, ShlObj, Dialogs;

type
TContextMenu = class(TComObject, IShellExtInit, IContextMenu)
private
FFileName: array[0..MAX_PATH] of Char;
protected
{ IShellExtInit }
function IShellExtInit.Initialize = SEIInitialize

function SEIInitialize(pidlFolder: PItemIDList
lpdobj: IDataObject;
hKeyProgID: HKEY): HResult
stdcall;
{ IContextMenu }
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;
end;

const
Class_ContextMenu: TGUID = '{45DEFB54-6F67-4997-B87C-D833CD6A01E0}';

implementation

uses ComServ, SysUtils, ShellApi, Registry;

function TContextMenu.SEIInitialize(pidlFolder: PItemIDList
lpdobj: IDataObject;
hKeyProgID: HKEY): HResult;
var
StgMedium: TStgMedium;
FormatEtc: TFormatEtc;
begin
//如果lpdobj等于Nil，则本调用失败
if (lpdobj = nil) then begin
Result := E_INVALIDARG;
Exit;
end;
//初始化剪贴板格式文件
with FormatEtc do begin
cfFormat := CF_HDROP;
ptd := nil;
dwAspect := DVASPECT_CONTENT;
lindex := -1;
tymed := TYMED_HGLOBAL;
end;

Result := lpdobj.GetData(FormatEtc, StgMedium);
if Failed(Result) then
Exit;
// If only one file is selected, retrieve the file name and store it in
// FFileName. Otherwise fail the call.
//如果选中了一个文件，将文件名存储到FFileName，否则本调用失败
if (DragQueryFile(StgMedium.hGlobal, $FFFFFFFF, nil, 0) = 1) then begin
DragQueryFile(StgMedium.hGlobal, 0, FFileName, SizeOf(FFileName));
Result := NOERROR;
end
else begin
FFileName[0] := #0;
Result := E_FAIL;
end;
ReleaseStgMedium(StgMedium);
end;

function TContextMenu.QueryContextMenu(Menu: HMENU
indexMenu, idCmdFirst,
idCmdLast, uFlags: UINT): HResult;
begin
Result := 0
// or use MakeResult(SEVERITY_SUCCESS, FACILITY_NULL, 0);

if ((uFlags and $0000000F) = CMF_NORMAL) or
((uFlags and CMF_EXPLORE) <> 0) then begin
//往 context menu 中加入一个菜单项
InsertMenu(Menu, indexMenu, MF_STRING or MF_BYPOSITION, idCmdFirst,
'打开此数据文件');

// Return number of menu items added
Result := 1
// or use MakeResult(SEVERITY_SUCCESS, FACILITY_NULL, 1)
end;
end;

function GetCompilerPath: string;
//返回 datalab.exe的路径
var
Reg: TRegistry;
begin
Reg := TRegistry.Create;
try
with Reg do begin
RootKey := HKEY_LOCAL_MACHINE;

OpenKey('/SOFTWARE/Hotinst/DataLab', False);
Result := ExpandFileName(ReadString('RootDir') + '/DataLab.exe');
end;
if AnsiPos(' ', Result) <> 0 then
Result := ExtractShortPathName(Result);
Result := Result + ' &quot;%s&quot;';
finally
Reg.Free;
end;
end;

function TContextMenu.InvokeCommand(var lpici: TCMInvokeCommandInfo): HResult;
resourcestring
sPathError = 'Error setting current directory';

var
H: THandle;
PrevDir: string;

begin
Result := E_FAIL;
//确定该过程是被系统而不是被一个程序所调用
if (HiWord(Integer(lpici.lpVerb)) <> 0) then
begin
Exit;
end;

// Make sure we aren't being passed an invalid argument number
//确定传递的参数的有效性
if (LoWord(lpici.lpVerb) <> 0) then begin
Result := E_INVALIDARG;
Exit;
end;


//用datalab.exe从lpici.lpVerb中调用文件
PrevDir := GetCurrentDir;
try
if not SetCurrentDir(ExtractFilePath(FFileName)) then
raise Exception.CreateRes(@sPathError);

H := WinExec(PChar(Format(GetCompilerPath, [FFileName])), lpici.nShow);

if (H < 32) then
MessageBox(lpici.hWnd, 'Error executing DataLab.exe .', 'Error',
MB_ICONERROR or MB_OK);
Result := NOERROR;
finally
SetCurrentDir(PrevDir);
end;
end;

function TContextMenu.GetCommandString(idCmd, uType: UINT
pwReserved: PUINT;
pszName: LPSTR
cchMax: UINT): HRESULT;
begin
if (idCmd = 0) then begin
if (uType = GCS_HELPTEXT) then

//从菜单项返回帮助字符
StrCopy(pszName, '用DataLab打开此数据文件');
Result := NOERROR;
end
else
Result := E_INVALIDARG;
end;

type
TContextMenuFactory = class(TComObjectFactory)
public
procedure UpdateRegistry(Register: Boolean)
override;
end;

procedure TContextMenuFactory.UpdateRegistry(Register: Boolean);
var
ClassID: string;
begin
if Register then begin
inherited UpdateRegistry(Register);

ClassID := GUIDToString(Class_ContextMenu);
CreateRegKey('DataLab/shellex', '', '');
CreateRegKey('DataLab/shellex/ContextMenuHandlers', '', '');
CreateRegKey('DataLab/shellex/ContextMenuHandlers/ContMenu', '', ClassID);

if (Win32Platform = VER_PLATFORM_WIN32_NT) then
with TRegistry.Create do
try
RootKey := HKEY_LOCAL_MACHINE;
OpenKey('SOFTWARE/Microsoft/Windows/CurrentVersion/Shell Extensions', True);
OpenKey('Approved', True);
WriteString(ClassID, 'DataLab Context Menu Shell Extension');
finally
Free;
end;
end
else begin
DeleteRegKey('DataLab/shellex/ContextMenuHandlers/ContMenu');
DeleteRegKey('DataLab/shellex/ContextMenuHandlers');
DeleteRegKey('DataLab/shellex')

inherited UpdateRegistry(Register);
end;
end;

initialization
TContextMenuFactory.Create(ComServer, TContextMenu, Class_ContextMenu,
'', 'DataLab Context Menu Shell Extension', ciMultiInstance,
tmApartment);
end.
 
您必须登录或注册才可回复。

Similar threads

I
利用delphi编写windows外壳扩展
回复
0
查看
594
import
I
I
注册到IE窗口
回复
0
查看
617
import
I
I
用delphi实现外壳扩展
回复
0
查看
634
import
I
X
应部分网友要求，公开 myfunctions 单元，里面有很多有用的函数(0)
回复
10
查看
4K
yczjs
Y
L
关于一个多线程分割下载文件的问题,请帮我看看,谢谢! 200分(100)
回复
4
查看
822
lzp_xiaoxian
L
后退
顶部