delphi 调用系统右键菜单

本文整理自网络，侵删。

 unit PopupMenuShell;
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 = '\';
Function String2PWideChar(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          CallbackWindow := CreateMenuCallbackWnd(ContextMenu2);
        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          Folder := nil;      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;begin  Result := nil;   s1:= ExtractFilePath(FileName);  s2:= ExtractFileName(FileName);  Path:= String2PWideChar(s1);  ItemName:= String2PWideChar(s2);
  if Succeeded(SHGetDesktopFolder(DesktopFolder)) then  begin    if Succeeded(DesktopFolder.ParseDisplayName(0, nil, Path, Eaten, PathIdList, Attr)) then    begin      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 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);  end;end;
end. 

相关阅读 >>

Delphi sqlite 自动编号的实现

Delphi获取ie浏览器url地址

Delphi二进制字符串转换成中文字符串

Delphi simple resource api replacement

Delphi判断字符串中是否包含汉字，并返回汉字位置

Delphi 删除cookies文件

Delphi 中的颜色常量及效果图

Delphi如何简单取得后缀名

Delphi firemonkey的屏幕分辨率hdpi、mdpi、ldpi的差别

Delphi downloadtomemory

更多相关阅读请进入《Delphi》频道 >>