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;
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;
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;