{ 在自己的界面中弹出系统右键菜单。}
unit PopupShell;
interface
uses
Windows, Messages, SysUtils, StrUtils, ComObj,
ShlObj,
ActiveX;
function DisplayContextMenu(const Handle: THandle; const FileName: string;
Pos: TPoint): Boolean;
implementation
type
TUnicodePath = array[0..MAX_PATH - 1] of WideChar;
const
ShenPathSeparator = '/';
//=============================================================================
//返回IDList去掉第一个ItemID后的IDList
function NextPIDL(IDList: PItemIDList): PItemIDList;
begin
Result := IDList;
Inc(PChar(Result), IDList^.mkid.cb);
end;
//返回IDList的长度
function GetPIDLSize(IDList: PItemIDList): Integer;
begin
Result := 0;
if Assigned(IDList) then
begin
Result := SizeOf(IDList^.mkid.cb);
while IDList^.mkid.cb <> 0 do
begin
Result := Result + IDList^.mkid.cb;
IDList := NextPIDL(IDList);
end;
end;
end;
//取得IDList中ItemID的个数
function GetItemCount(IDList: PItemIDList): Integer;
begin
Result := 0;
while IDList^.mkid.cb <> 0 do
begin
Inc(Result);
IDList := NextPIDL(IDList);
end;
end;
//创建一ItemIDList对象
function CreatePIDL(Size: Integer): PItemIDList;
var
Malloc: IMalloc;
begin
OleCheck(SHGetMalloc(Malloc));
Result := Malloc.Alloc(Size);
if Assigned(Result) then
FillChar(Result^, Size, 0);
end;
//返回IDList的一个内存拷贝
function CopyPIDL(IDList: PItemIDList): PItemIDList;
var
Size: Integer;
begin
Size := GetPIDLSize(IDList);
Result := CreatePIDL(Size);
if Assigned(Result) then
CopyMemory(Result, IDList, Size);
end;
//返回AbsoluteID最后一个ItemID，即此对象相对于父对象的ItemID
function RelativeFromAbsolute(AbsoluteID: PItemIDList): PItemIDList;
begin
Result := AbsoluteID;
while GetItemCount(Result) > 1 do
Result := NextPIDL(Result);
Result := CopyPIDL(Result);
end;
//将IDList的最后一个ItemID去掉，即得到IDList的父对象的ItemID
procedure StripLastID(IDList: PItemIDList);
var
MarkerID: PItemIDList;
begin
MarkerID := IDList;
if Assigned(IDList) then
begin
while IDList.mkid.cb <> 0 do
begin
MarkerID := IDList;
IDList := NextPIDL(IDList);
end;
MarkerID.mkid.cb := 0;
end;
end;
// 类型转换 PWideChar，不用StringToOleStr，测试存在内存泄
Function A2U(const s: String): PWideChar;
begin
if s = '' then begin
result:= nil;
exit;
end;
result:= AllocMem((Length(s) + 1) * sizeOf(widechar));
StringToWidechar(s, result, Length(s) * sizeOf(widechar) + 1);
end;
//=============================================================================
function PidlFree(var IdList: PItemIdList): Boolean;
var
Malloc: IMalloc;
begin
Result := False;
if IdList = nil then
Result := True
else
begin
if Succeeded(SHGetMalloc(Malloc)) and (Malloc.DidAlloc(IdList) > 0) then
begin
Malloc.Free(IdList);
IdList := nil;
Result := True;
end;
end;
end;
function MenuCallback(Wnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM):
LRESULT; stdcall;
var
ContextMenu2: IContextMenu2;
begin
case Msg of
WM_CREATE:
begin
ContextMenu2 := IContextMenu2(PCreateStruct(lParam).lpCreateParams);
SetWindowLong(Wnd, GWL_USERDATA, Longint(ContextMenu2));
Result := DefWindowProc(Wnd, Msg, wParam, lParam);
end;
WM_INITMENUPOPUP:
begin
ContextMenu2 := IContextMenu2(GetWindowLong(Wnd, GWL_USERDATA));
ContextMenu2.HandleMenuMsg(Msg, wParam, lParam);
Result := 0;
end;
WM_DRAWITEM, WM_MEASUREITEM:
begin
ContextMenu2 := IContextMenu2(GetWindowLong(Wnd, GWL_USERDATA));
ContextMenu2.HandleMenuMsg(Msg, wParam, lParam);
Result := 1;
end;
else
Result := DefWindowProc(Wnd, Msg, wParam, lParam);
end;
end;
function CreateMenuCallbackWnd(const ContextMenu: IContextMenu2): HWND;
const
IcmCallbackWnd = 'ICMCALLBACKWND';
var
WndClass: TWndClass;
begin
FillChar(WndClass, SizeOf(WndClass), #0);
WndClass.lpszClassName := PChar(IcmCallbackWnd);
WndClass.lpfnWndProc := @MenuCallback;
WndClass.hInstance := HInstance;
Windows.RegisterClass(WndClass);
Result := CreateWindow(IcmCallbackWnd, IcmCallbackWnd, WS_POPUPWINDOW, 0,
0, 0, 0, 0, 0, HInstance, Pointer(ContextMenu));
end;
function DisplayContextMenuPidl(const Handle: HWND; const Folder: IShellFolder;
Item: PItemIdList; Pos: TPoint): Boolean;
var
Cmd: Cardinal;
ContextMenu: IContextMenu;
ContextMenu2: IContextMenu2;
Menu: HMENU;
CommandInfo: TCMInvokeCommandInfo;
CallbackWindow: HWND;
begin
Result := False;
if (Item = nil) or (Folder = nil) then
Exit;
Folder.GetUIObjectOf(Handle, 1, Item, IID_IContextMenu, nil,
Pointer(ContextMenu));
if ContextMenu <> nil then
begin
Menu := CreatePopupMenu;
if Menu <> 0 then
begin
if Succeeded(ContextMenu.QueryContextMenu(Menu, 0, 1, $7FFF, CMF_EXPLORE))
then
begin
CallbackWindow := 0;
if Succeeded(ContextMenu.QueryInterface(IContextMenu2, ContextMenu2))
then
begin
CallbackWindow := CreateMenuCallbackWnd(ContextMenu2);
end;
ClientToScreen(Handle, Pos);
Cmd := Cardinal(TrackPopupMenu(Menu, TPM_LEFTALIGN or TPM_LEFTBUTTON or
TPM_RIGHTBUTTON or TPM_RETURNCMD, Pos.X, Pos.Y, 0, CallbackWindow,
nil));
if Cmd <> 0 then
begin
FillChar(CommandInfo, SizeOf(CommandInfo), #0);
CommandInfo.cbSize := SizeOf(TCMInvokeCommandInfo);
CommandInfo.hwnd := Handle;
CommandInfo.lpVerb := MakeIntResource(Cmd - 1);
CommandInfo.nShow := SW_SHOWNORMAL;
Result := Succeeded(ContextMenu.InvokeCommand(CommandInfo));
end;
if CallbackWindow <> 0 then
DestroyWindow(CallbackWindow);
end;
DestroyMenu(Menu);
end;
end;
end;
function PathAddSeparator(const Path: string): string;
begin
Result := Path;
if (Length(Path) = 0) or (AnsiLastChar(Path) <> ShenPathSeparator) then
Result := Path + ShenPathSeparator;
end;
function DriveToPidlBind(const DriveName: string; out Folder: IShellFolder):
PItemIdList;
var
Attr: ULONG;
Eaten: ULONG;
DesktopFolder: IShellFolder;
Drives: PItemIdList;
Path: TUnicodePath;
begin
Result := nil;
if Succeeded(SHGetDesktopFolder(DesktopFolder)) then begin
if Succeeded(SHGetSpecialFolderLocation(0, CSIDL_DRIVES, Drives)) then begin
if Succeeded(DesktopFolder.BindToObject(Drives, nil, IID_IShellFolder, Pointer(Folder))) then begin
MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, PChar(PathAddSeparator(DriveName)), -1, Path, MAX_PATH);
if FAILED(Folder.ParseDisplayName(0, nil, Path, Eaten, Result, Attr)) then begin
Folder := nil;
end;
end;
end;
PidlFree(Drives);
end;
end;
function PathToPidlBind(const FileName: string; out Folder: IShellFolder):
PItemIdList;
var
Attr, Eaten: ULONG;
PathIdList: PItemIdList;
DesktopFolder: IShellFolder;
Path, ItemName: pwidechar;
s1,s2: string;
k: integer;
begin
Result := nil;
s1:= ExtractFilePath(FileName);
s2:= ExtractFileName(FileName);
Path:= a2u(s1);
ItemName:= a2u(s2);
if Succeeded(SHGetDesktopFolder(DesktopFolder)) then begin
if Succeeded(DesktopFolder.ParseDisplayName(0, nil, Path, Eaten, PathIdList, Attr)) then begin // FAIL
if Succeeded(DesktopFolder.BindToObject(PathIdList, nil, IID_IShellFolder, Pointer(Folder))) then begin
if FAILED(Folder.ParseDisplayName(0, nil, ItemName, Eaten, Result, Attr)) then begin
Folder := nil;
Result := DriveToPidlBind(FileName, Folder);
end;
end;
PidlFree(PathIdList);
end
else
Result := DriveToPidlBind(FileName, Folder);
end;
FreeMem(Path);
FreeMem(ItemName);
end;
function LANToPidlBind(NetPath: string; out Folder: IShellFolder): PItemIdList;
var
Attr, Eaten: ULONG;
DesktopFolder: IShellFolder;
nt,pid1,pid2: PItemIdList;
Path,FullPath: pwidechar;
s1,s2: string;
k: integer;
err: HResult;
begin
Result := nil;
end;
function DisplayContextMenu(const Handle: Thandle; const FileName: string; Pos: TPoint): Boolean;
var
ItemIdList: PItemIdList;
Folder: IShellFolder;
begin
Result := False;
ItemIdList := PathToPidlBind(FileName, Folder);
if ItemIdList <> nil then
begin
Result := DisplayContextMenuPidl(Handle, Folder, ItemIdList, Pos);
PidlFree(ItemIdList);
//Folder:= nil;
end;
end;
end.
// ========================================= //
procedure TFormTest.Button59Click(Sender: TObject);
var
pos: TPoint;
begin
GetCursorPos(pos);
pos:= ScreenToClient(pos);
DisplayContextMenu(handle, 'c:/tools/setup', pos);
end;