1 unit PopupMenuShell;
  2 
  3 interface
  4 
  5 uses
  6   Windows, Messages, SysUtils, StrUtils, ComObj, ShlObj, ActiveX;
  7 
  8 function DisplayContextMenu(const Handle: THandle; const FileName: string; Pos: TPoint): Boolean;
  9 
 10 implementation
 11 
 12 type
 13   TUnicodePath = array[0..MAX_PATH - 1] of WideChar;
 14 
 15 const
 16   ShenPathSeparator = '\';
 17 
 18 Function String2PWideChar(const s: String): PWideChar;
 19 begin
 20   if s = '' then
 21   begin
 22     result:= nil;
 23     exit;
 24   end;
 25   result:= AllocMem((Length(s) + 1) * sizeOf(widechar));
 26   StringToWidechar(s, result, Length(s) * sizeOf(widechar) + 1);
 27 end;
 28 
 29 function PidlFree(var IdList: PItemIdList): Boolean;
 30 var
 31   Malloc: IMalloc;
 32 begin
 33   Result := False;
 34   if IdList = nil then
 35     Result := True
 36   else
 37   begin
 38     if Succeeded(SHGetMalloc(Malloc)) and (Malloc.DidAlloc(IdList) > 0) then
 39     begin
 40       Malloc.Free(IdList);
 41       IdList := nil;
 42       Result := True;
 43     end;
 44   end;
 45 end;
 46 
 47 function MenuCallback(Wnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
 48 var
 49   ContextMenu2: IContextMenu2;
 50 begin
 51   case Msg of
 52     WM_CREATE:
 53       begin
 54         ContextMenu2 := IContextMenu2(PCreateStruct(lParam).lpCreateParams);
 55         SetWindowLong(Wnd, GWL_USERDATA, Longint(ContextMenu2));
 56         Result := DefWindowProc(Wnd, Msg, wParam, lParam);
 57       end;
 58     WM_INITMENUPOPUP:
 59       begin
 60         ContextMenu2 := IContextMenu2(GetWindowLong(Wnd, GWL_USERDATA));
 61         ContextMenu2.HandleMenuMsg(Msg, wParam, lParam);
 62         Result := 0;
 63       end;
 64     WM_DRAWITEM, WM_MEASUREITEM:
 65       begin
 66         ContextMenu2 := IContextMenu2(GetWindowLong(Wnd, GWL_USERDATA));
 67         ContextMenu2.HandleMenuMsg(Msg, wParam, lParam);
 68         Result := 1;
 69       end;
 70   else
 71     Result := DefWindowProc(Wnd, Msg, wParam, lParam);
 72   end;
 73 end;
 74 
 75 function CreateMenuCallbackWnd(const ContextMenu: IContextMenu2): HWND;
 76 const
 77   IcmCallbackWnd = 'ICMCALLBACKWND';
 78 var
 79   WndClass: TWndClass;
 80 begin
 81   FillChar(WndClass, SizeOf(WndClass), #0);
 82   WndClass.lpszClassName := PChar(IcmCallbackWnd);
 83   WndClass.lpfnWndProc := @MenuCallback;
 84   WndClass.hInstance := HInstance;
 85   Windows.RegisterClass(WndClass);
 86   Result := CreateWindow(IcmCallbackWnd, IcmCallbackWnd, WS_POPUPWINDOW, 0, 0, 0, 0, 0, 0, HInstance, Pointer(ContextMenu));
 87 end;
 88 
 89 function DisplayContextMenuPidl(const Handle: HWND; const Folder: IShellFolder; Item: PItemIdList; Pos: TPoint): Boolean;
 90 var
 91   Cmd: Cardinal;
 92   ContextMenu: IContextMenu;
 93   ContextMenu2: IContextMenu2;
 94   Menu: HMENU;
 95   CommandInfo: TCMInvokeCommandInfo;
 96   CallbackWindow: HWND;
 97 begin
 98   Result := False;
 99   if (Item = nil) or (Folder = nil) then
100     Exit;
101   Folder.GetUIObjectOf(Handle, 1, Item, IID_IContextMenu, nil, Pointer(ContextMenu));
102 
103   if ContextMenu <> nil then
104   begin
105     Menu := CreatePopupMenu;
106     if Menu <> 0 then
107     begin
108       if Succeeded(ContextMenu.QueryContextMenu(Menu, 0, 1, $7FFF, CMF_EXPLORE)) then
109       begin
110         CallbackWindow := 0;
111 
112         if Succeeded(ContextMenu.QueryInterface(IContextMenu2, ContextMenu2)) then
113           CallbackWindow := CreateMenuCallbackWnd(ContextMenu2);
114 
115         ClientToScreen(Handle, Pos);
116         Cmd := Cardinal(TrackPopupMenu(Menu, TPM_LEFTALIGN or TPM_LEFTBUTTON or
117           TPM_RIGHTBUTTON or TPM_RETURNCMD, Pos.X, Pos.Y, 0, CallbackWindow,
118           nil));
119 
120         if Cmd <> 0 then
121         begin
122           FillChar(CommandInfo, SizeOf(CommandInfo), #0);
123           CommandInfo.cbSize := SizeOf(TCMInvokeCommandInfo);
124           CommandInfo.hwnd := Handle;
125           CommandInfo.lpVerb := MakeIntResource(Cmd - 1);
126           CommandInfo.nShow := SW_SHOWNORMAL;
127           Result := Succeeded(ContextMenu.InvokeCommand(CommandInfo));
128         end;
129 
130         if CallbackWindow <> 0 then
131           DestroyWindow(CallbackWindow);
132       end;
133 
134       DestroyMenu(Menu);
135     end;
136   end;
137 end;
138 
139 function PathAddSeparator(const Path: string): string;
140 begin
141   Result := Path;
142   if (Length(Path) = 0) or (AnsiLastChar(Path) <> ShenPathSeparator) then
143     Result := Path + ShenPathSeparator;
144 end;
145 
146 function DriveToPidlBind(const DriveName: string; out Folder: IShellFolder):
147   PItemIdList;
148 var
149   Attr: ULONG;
150   Eaten: ULONG;
151   DesktopFolder: IShellFolder;
152   Drives: PItemIdList;
153   Path: TUnicodePath;
154 begin
155   Result := nil;
156   if Succeeded(SHGetDesktopFolder(DesktopFolder)) then
157   begin
158     if Succeeded(SHGetSpecialFolderLocation(0, CSIDL_DRIVES, Drives)) then
159     begin
160       if Succeeded(DesktopFolder.BindToObject(Drives, nil, IID_IShellFolder, Pointer(Folder))) then
161       begin
162         MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, PChar(PathAddSeparator(DriveName)), -1, Path, MAX_PATH);
163 
164         if Failed(Folder.ParseDisplayName(0, nil, Path, Eaten, Result, Attr)) then
165           Folder := nil;
166       end;
167     end;
168     PidlFree(Drives);
169   end;
170 end;
171 
172 function PathToPidlBind(const FileName: string; out Folder: IShellFolder): PItemIdList;
173 var
174   Attr, Eaten: ULONG;
175   PathIdList: PItemIdList;
176   DesktopFolder: IShellFolder;
177   Path, ItemName: pwidechar;
178   s1,s2: string;
179 begin
180   Result := nil;
181  
182   s1:= ExtractFilePath(FileName);
183   s2:= ExtractFileName(FileName);
184   Path:= String2PWideChar(s1);
185   ItemName:= String2PWideChar(s2);
186 
187   if Succeeded(SHGetDesktopFolder(DesktopFolder)) then
188   begin
189     if Succeeded(DesktopFolder.ParseDisplayName(0, nil, Path, Eaten, PathIdList, Attr)) then
190     begin
191       if Succeeded(DesktopFolder.BindToObject(PathIdList, nil, IID_IShellFolder, Pointer(Folder))) then
192       begin
193         if Failed(Folder.ParseDisplayName(0, nil, ItemName, Eaten, Result, Attr)) then
194         begin
195           Folder := nil;
196           Result := DriveToPidlBind(FileName, Folder);
197         end;
198       end;
199       PidlFree(PathIdList);
200     end
201     else
202       Result := DriveToPidlBind(FileName, Folder);
203   end;
204 
205   FreeMem(Path);
206   FreeMem(ItemName);
207 end;
208 
209 function DisplayContextMenu(const Handle: Thandle; const FileName: string; Pos: TPoint): Boolean;
210 var
211   ItemIdList: PItemIdList;
212   Folder: IShellFolder;
213 begin
214   Result := False;
215   ItemIdList := PathToPidlBind(FileName, Folder);
216 
217   if ItemIdList <> nil then
218   begin
219     Result := DisplayContextMenuPidl(Handle, Folder, ItemIdList, Pos);
220     PidlFree(ItemIdList);
221   end;
222 end;
223 
224 end.