////////////////////////////////////////////////////////////////////////////////

//

//  ****************************************************************************

//  * 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, FFF, 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.