这是我简单修改了的代码：
unit YHCMImpl;
{$WARN SYMBOL_PLATFORM OFF}
interface
uses
Windows, ActiveX, Classes, ComObj, StdVcl,Messages,SysUtils, ShellAPI, ShlObj, Graphics, JPEG, Registry;
type
TYHContextMenu = class(TComObject,IShellExtInit)
private
FFileList : TStringList; //存放文件列表
FGraphic : TGraphic; //用于执行图片预览的动作
protected
{ IShellExtInit 接口 }
function IShellExtInit.Initialize = SEInitialize;
function SEInitialize(pidlFolder: PItemIDList; lpdobj: IDataObject;hKeyProgID: HKEY): HResult; stdcall;
function InvokeCommand(var lpici: TCMInvokeCommandInfo): HResult;
function GetCommandString(idCmd, uType: UINT; pwReserved: PUINT; pszName: LPSTR; cchMax: UINT): HResult;
public
procedure Initialize; override;
destructor Destroy; override;
function QueryContextMenu(Menu: HMENU; indexMenu, idCmdFirst, idCmdLast, uFlags: UINT): HResult;
end;
TYHContextMenuFactory = class(TComObjectFactory)
public
procedure UpdateRegistry(Register: Boolean); override;
end;
const
Class_YHContextMenu: TGUID = '{0C228FF2-015A-410B-8B67-DF489E9A53F9}';
// 菜单类型
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;
implementation
uses ComServ;
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;
function TYHContextMenu.SEInitialize(pidlFolder: PItemIDList; lpdobj: IDataObject; hKeyProgID: HKEY): HResult;
begin
OutputDebugString('YHContextMenu::SEInitialize');//向调试器发送一个字符串，告知调试信息。
//Result := GetFileListFromDataObject(lpdobj, FFileList);
Result := S_OK ;
end;
procedure TYHContextMenu.Initialize;
begin
OutputDebugString('YHContextMenu::Initialize');//向调试器发送一个字符串，告知调试信息。
inherited;
FFileList := TStringList.Create;
FGraphic := nil;
end;
destructor TYHContextMenu.Destroy;
begin
OutputDebugString('YHContextMenu::Destroy');
FreeAndNil(FFileList);
FreeAndNil(FGraphic);
inherited;
end;
// 在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 TYHContextMenu.QueryContextMenu(Menu: HMENU; indexMenu, idCmdFirst, idCmdLast, uFlags: UINT): HResult;
var
Added: UINT;
begin
OutputDebugString('YHContextMenu::QueryContextMenu');//向调试器发送一个字符串，告知调试信息。
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, '你好！');
InsertMenu(Menu, indexMenu, mfSeparator, 0, nil);
Inc(Added, 3);
Result := Make_HResult(SEVERITY_SUCCESS, FACILITY_NULL, idMenuRange);
end;
procedure DoCopyAnywhere(Wnd: HWND; sl: TStringList);
begin
OutputDebugString('YHContextMenu::DoCopyAnywhere');//向调试器发送一个字符串，告知调试信息。
end;
function TYHContextMenu.InvokeCommand(var lpici: TCMInvokeCommandInfo): HResult;
begin
OutputDebugString('YHContextMenu::InvokeCommand');//向调试器发送一个字符串，告知调试信息。
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;
function TYHContextMenu.GetCommandString(idCmd, uType: UINT; pwReserved: PUINT; pszName: LPSTR; cchMax: UINT): HResult;
var
strTip: String;
wstrTip: WideString;
begin
OutputDebugString('YHContextMenu::GetCommandString');//向调试器发送一个字符串，告知调试信息。
strTip := '';
Result := E_INVALIDARG;
if (uType and GCS_HELPTEXT)<> GCS_HELPTEXT then Exit;
case idCmd of
idCopyAnywhere: strTip := 'hehe';
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;
procedure DeleteRegValue(const Path, ValueName: String; Root: DWord=HKEY_CLASSES_ROOT);
var
reg: TRegistry;
begin
OutputDebugString('YHContextMenu::DeleteRegValue');//向调试器发送一个字符串，告知调试信息。
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;
procedure TYHContextMenuFactory.UpdateRegistry(Register: Boolean);
const
RegPath = '*/shellex/ContextMenuHandlers/CCShellExt';
ApprovedPath = 'Software/Microsoft/Windows/CurrentVersion/ShellExtensions/Approved';
var
strGUID: String;
begin
OutputDebugString('YHContextMenu::UpdateRegistry');//向调试器发送一个字符串，告知调试信息。
inherited UpdateRegistry(Register);
strGUID := GUIDToString(Class_YHContextMenu);
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
TComObjectFactory.Create(ComServer, TYHContextMenu, Class_YHContextMenu,
'YHContextMenu', '', ciMultiInstance, tmApartment);
end.
本版专家分：2结帖率 100%
