////////////////////////////////////////////////////////////////////////////////
//
// ****************************************************************************
// * Unit Name : Unit1
// * Purpose : Демо отображения системного контекстного меню эксплорера
// * Author : Александр (Rouse_) Багель
// * Version : 1.00
// ****************************************************************************
//
unit Unit1;
interface
uses
 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
 Dialogs, StdCtrls,
 // Чтоб все заработало - подключаем вот эти 2 юнита
 ShlObj,
 ActiveX;
type
 TForm1 = class(TForm)
  Button1: TButton;
  procedure Button1Click(Sender: TObject);
 end;
var
 Form1: TForm1;
implementation
{$R *.dfm}
// Это для работы самого меню, как оконного элемента
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;
procedure GetProperties(Path: String; MousePoint: TPoint; WC: TWinControl);
var
 CoInit, AResult: HRESULT;
 CommonDir, FileName: String;
 Desktop, ShellFolder: IShellFolder;
 pchEaten, Attr: Cardinal;
 PathPIDL: PItemIDList;
 FilePIDL: array [0..1] of PItemIDList;
 ShellContextMenu: HMenu;
 ICMenu: IContextMenu;
 ICMenu2: IContextMenu2;
 PopupMenuResult: BOOL;
 CMD: TCMInvokeCommandInfo;
 M: IMAlloc;
 ICmd: Integer;
 CallbackWindow: HWND;
begin
 // Первичная инициализация
 ShellContextMenu := 0;
 Attr := 0;
 PathPIDL := nil;
 CallbackWindow := 0;
 CoInit := CoInitializeEx(nil, COINIT_MULTITHREADED);
 try
  // Получаем пути и имя фала
  CommonDir := ExtractFilePath(Path);
  FileName := ExtractFileName(Path);
  // Получаем указатель на интерфейс рабочего стола
  if SHGetDesktopFolder(Desktop) <> S_OK then
  RaiseLastOSError;
  // Если работаем с папкой
  if FileName = '' then
  begin
  // Получаем указатель на папку "Мой компьютер"
  if (SHGetSpecialFolderLocation(0, CSIDL_DRIVES, PathPIDL) <> S_OK) or
  (Desktop.BindToObject(PathPIDL, nil, IID_IShellFolder,
  Pointer(ShellFolder)) <> S_OK) then RaiseLastOSError;
  // Получаем указатель на директорию
  ShellFolder.ParseDisplayName(WC.Handle, nil, StringToOleStr(CommonDir),
  pchEaten, FilePIDL[0], Attr);
  // Получаем указатель на контектсное меню папки
  AResult := ShellFolder.GetUIObjectOf(WC.Handle, 1, FilePIDL[0],
  IID_IContextMenu, nil, Pointer(ICMenu));
  end
  else
  begin
  // Получаем указатель на папку "Мой компьютер"
  if (Desktop.ParseDisplayName(WC.Handle, nil, StringToOleStr(CommonDir),
  pchEaten, PathPIDL, Attr) <> S_OK) or
  (Desktop.BindToObject(PathPIDL, nil, IID_IShellFolder,
  Pointer(ShellFolder)) <> S_OK) then RaiseLastOSError;
  // Получаем указатель на файл
  ShellFolder.ParseDisplayName(WC.Handle, nil, StringToOleStr(FileName),
  pchEaten, FilePIDL[0], Attr);
  // Получаем указатель на контектсное меню файла
  AResult := ShellFolder.GetUIObjectOf(WC.Handle, 1, FilePIDL[0],
  IID_IContextMenu, nil, Pointer(ICMenu));
  end;
  // Если указатель на конт. меню есть, делаем так:
  if Succeeded(AResult) then
  begin
  ICMenu2 := nil;
  // Создаем меню
  ShellContextMenu := CreatePopupMenu;
  // Производим его наполнение
  if Succeeded(ICMenu.QueryContextMenu(ShellContextMenu, 0,
  1, $7FFF, CMF_EXPLORE)) and
  Succeeded(ICMenu.QueryInterface(IContextMenu2, ICMenu2)) then
  CallbackWindow := CreateMenuCallbackWnd(ICMenu2);
  try
  // Показываем меню
  PopupMenuResult := TrackPopupMenu(ShellContextMenu, TPM_LEFTALIGN or TPM_LEFTBUTTON
  or TPM_RIGHTBUTTON or TPM_RETURNCMD,
  MousePoint.X, MousePoint.Y, 0, CallbackWindow, nil);
  finally
  ICMenu2 := nil;
  end;
  // Если был выбран какой либо пункт меню:
  if PopupMenuResult then
  begin
  // Индекс этого пункта будет лежать в ICmd
  ICmd := LongInt(PopupMenuResult) - 1;
  // Заполняем структуру TCMInvokeCommandInfo
  FillChar(CMD, SizeOf(CMD), #0);
  with CMD do
  begin
  cbSize := SizeOf(CMD);
  hWND := WC.Handle;
  lpVerb := MakeIntResource(ICmd);
  nShow := SW_SHOWNORMAL;
  end;
  // Выполняем InvokeCommand с заполненной структурой
  AResult := ICMenu.InvokeCommand(CMD);
  if AResult <> S_OK then RaiseLastOSError;
  end;
  end;
 finally
  // Освобождаем занятые ресурсы чтобы небыло утечки памяти
  if FilePIDL[0] <> nil then
  begin
  // Для освобождения использем IMalloc
  SHGetMAlloc(M);
  if M <> nil then
  M.Free(FilePIDL[0]);
  M:=nil;
  end;
  if PathPIDL <> nil then
  begin
  SHGetMAlloc(M);
  if M <> nil then
  M.Free(PathPIDL);
  M:=nil;
  end;
  if ShellContextMenu <>0 then
  DestroyMenu(ShellContextMenu);
  if CallbackWindow <> 0 then
  DestroyWindow(CallbackWindow);
  ICMenu := nil;
  ShellFolder := nil;
  Desktop := nil;
  if CoInit = S_OK then CoUninitialize;
 end;
end;
// Пример использования
procedure TForm1.Button1Click(Sender: TObject);
var
 pt: TPoint;
begin
 GetCursorPos(pt);
 GetProperties('E:\Guardant\INSTDRV.INI', pt, Self);
end;
end.