Отображение системного контекстного меню эксплорера.

← →
Nikfel © (2007-09-03 12:35) [0]

Пожалуйста помогите перевести код под kol:
////////////////////////////////////////////////////////////////////////////////
//
// ****************************************************************************
// * Unit Name : uSysPopupMain
// * Purpose : Демо отображения системного контекстного меню эксплорера.
// * Author : Александр (Rouse_) Багель
// * Version : 1.00
// ****************************************************************************
//
unit uSysPopupMain;

interface

uses
Windows, Messages, SysUtils, Controls,
ShlObj, ActiveX;

procedure Set_Explorer_Popup_Menu(pt:TPoint;strName:string;F:TWinControl);

implementation
// Это для работы самого меню, как оконного элемента
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 Set_Explorer_Popup_Menu(pt:TPoint;strName:string;F:TWinControl);
begin
GetProperties(strName, pt, F);
end;

end.

Пример работы в:
http://www.delphisources.ru/files/sources/system/2006_year/expl_popup_menu.zip

← →
Дмитрий К © (2007-09-03 13:42) [1]

program KOLSysPopup; uses windows, messages, kol, ShlObj, ActiveX; type PForm1 = ^TForm1; TForm1 = object(TObj) form, lbl, edt, btn: PControl; public procedure DoClick(Sender: PObj); end; var Form1: PForm1; procedure NewForm1(var Result: PForm1; AParent: PControl); begin New(Result, Create); with Result^ do begin form := NewForm(AParent, "popup"); Applet := form; form.add2AutoFree(Result); lbl := NewLabel(form,"Enter path").AutoSize(True); edt := NewEditBox(form, []).SetSize(300,0).PlaceUnder; edt.text := "c:\"; btn := NewButton(form, "Show").PlaceRight.ResizeParent; btn.OnClick := DoClick; 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; procedure GetProperties(Path: String; MousePoint: TPoint; WC: PControl); 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 msgok(SysErrorMessage(GetLastError)); if FileName = "" then begin if (SHGetSpecialFolderLocation(0, CSIDL_DRIVES, PathPIDL) <> S_OK) or (Desktop.BindToObject(PathPIDL, nil, IID_IShellFolder, Pointer(ShellFolder)) <> S_OK) then msgok(SysErrorMessage(GetLastError)); 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 msgok(SysErrorMessage(GetLastError)); 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 := LongInt(PopupMenuResult) - 1; FillChar(CMD, SizeOf(CMD), #0); with CMD do begin cbSize := SizeOf(CMD); hWND := WC.Handle; lpVerb := MakeIntResource(ICmd); nShow := SW_SHOWNORMAL; end; AResult := ICMenu.InvokeCommand(CMD); if AResult <> S_OK then msgok(SysErrorMessage(GetLastError)); end; end; finally if FilePIDL[0] <> nil then begin 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.DoClick(Sender: PObj); var pt: TPoint; begin GetCursorPos(pt); GetProperties(edt.Text, pt, form); end; begin NewForm1(Form1, nil); Run(Applet); end.

← →
Nikfel © (2007-09-03 17:00) [2]

Проверил код. Он работает, но почему-то в пункте отправить программа виснет.

← →
Nikfel © (2007-09-03 17:11) [3]

За код спасибо. Кто-нибудь может сказать как спрятать пункт отправить, а то у меня программа виснет.

← →
Nikfel © (2007-09-03 17:34) [4]

Нашел способ как избавиться от пункта отправить. Надо удалить:
HKEY_CLASSES_ROOT\AllFilesystemObjects\shellex\ContextMenuHandlers\Send To
Но может есть что-то по лудше. Этот способ не удобен.

← →
Nikfel © (2007-09-04 14:54) [5]

Нашел в интернете отличный код:
unit Unit2;

interface

uses Windows, ActiveX, ShlObj, Messages, kol;

function DisplayContextMenu(const Handle: HWND; const FileName: string; Pos: TPoint): Boolean;

implementation

// Window procedure for the callback window created by DisplayContextMenu.
// It simply forwards messages to the folder. If you don"t do this then the
// system created submenu"s will be empty (except for 1 stub item!)
// note: storing the IContextMenu2 pointer in the window"s user data was
// "inspired" by (read: copied from) code by Brad Stowers.

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;

//------------------------------------------------------------------------------

// Helper function for DisplayContextMenu, creates the callback window.

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;
// TODO If Folder = nil then PidlBindToParent ?
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(Folder: string):string;
begin
result := Folder + "\";
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 DriveToPidlBind(const DriveName: string;
out Folder: IShellFolder): PItemIdList;
var
Attr: ULONG;
Eaten: ULONG;
DesktopFolder: IShellFolder;
Drives: PItemIdList;
Path: array [0..MAX_PATH] of WideChar;
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;
// Failure probably means that this is not a drive. However, do not
// call PathToPidlBind() because it may cause infinite recursion.
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: array [0..MAX_PATH] of WideChar;
begin
Result := nil;
MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, PChar(ExtractFilePath(FileName)), -1, Path, MAX_PATH);
MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, PChar(ExtractFileName(FileName)), -1, ItemName, MAX_PATH);
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;
end;

function DisplayContextMenu(const Handle: HWND; 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.

← →
MTsv DN © (2007-09-18 16:36) [6]

Привет.

Решил снова поднять данную тему. Все три кода показывают, как я понял, стандартное меню Проводника, то которое мы имеем сразу после установки Винды. Однако, на сайте Уважаемого Александра (Rouse_) Багеля (см. [0], есть новый код в котором используется COM-объекты для отображения полного меню Проводника (с архиваторами, антивирусами и прочими).

Начал портировать под KOL и столкнулся со следующей проблемой: http://slil.ru/24871648 Как видно, используются одни и те же юниты и код...однако, в случае использования KOL мы не получаем желаемого результата... Отсюда вопрос: Почему???

З.Ы. То, что используются SysUtils и Classes мне без разницы...

← →
ANTPro © (2007-09-18 17:13) [7]

> [6] MTsv DN © (18.09.07 16:36)

Попробуй юзать не KOLComObj, а стандартный ComObj.
PS: Архив не смотрел еще.

← →
MTsv DN © (2007-09-18 17:48) [8]

> Попробуй юзать не KOLComObj, а стандартный ComObj
Пробовал...не помогает. Тем более, что не-KOL версия и с KOLComObj
правильно работает...

← →
MTsv DN © (2007-09-19 10:10) [9]

Привет.

> Решил снова поднять данную тему. Все три кода показывают, как я понял, стандартное меню Проводника, то которое мы имеем сразу после установки Винды. Однако, на сайте Уважаемого Александра (Rouse_) Багеля (см. [0], есть новый код в котором используется COM-объекты для отображения полного меню Проводника (с архиваторами, антивирусами и прочими).
>
> Начал портировать под KOL и столкнулся со следующей проблемой: http://slil.ru/24871648 Как видно, используются одни и те же юниты и код...однако, в случае использования KOL мы не получаем желаемого результата... Отсюда вопрос: Почему???
>
> З.Ы. То, что используются SysUtils и Classes мне без разницы...
Наконец-то разобрался где "косячило"... Вот минимальный проект: http://ifolder.ru/3398396

← →
Дмитрий К © (2007-09-19 12:39) [10]

> Наконец-то разобрался где "косячило"... Вот минимальный
> проект: http://ifolder.ru/3398396

+1

В связи с этим, чтобы заработал код из [1] нужно поменять
CoInit := CoInitializeEx(nil, COINIT_MULTITHREADED);
на
CoInit := CoInitializeEx(nil, COINIT_APARTMENTTHREADED);

← →
Nikfel © (2007-09-19 18:30) [11]

Большое спасибо за код. Для работы кода похоже требуется err.pas, который пришлось скачать с http://kolmck.net/

← →
MTsv DN © (2007-09-22 14:37) [12]

Всем привет...

Этот код:
> http://ifolder.ru/3398396
прекрасно работает если передавать один элемент, например, полный путь к файлу. Но ведь можно передавать группу элементов, как поступать в этом случае??? Подскажите...

← →
MTsv DN © (2007-09-26 15:36) [13]

Всем привет...

> прекрасно работает если передавать один элемент, например, полный путь к файлу. Но ведь можно передавать группу элементов, как поступать в этом случае??? Подскажите...
В заключение темы, отвечу на свой вопрос сам:

(*======================================================================== ====*) // Это для работы самого меню, как оконного элемента 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;

← →
MTsv DN © (2007-09-26 15:37) [14]

// Это для создания самого меню, как оконного элемента
function CreateMenuCallbackWnd(const ContextMenu: IContextMenu2): HWND;
const
IcmCallbackWnd = "ICMCALLBACKWND";
var
WndClass: {$IFDEF UNICODE_CTRLS}TWndClassW{$ELSE}TWndClassA{$ENDIF};
begin
FillChar(WndClass, SizeOf(WndClass), #0);
WndClass.lpszClassName := PKOLChar(KOLString(IcmCallbackWnd));
WndClass.lpfnWndProc := @MenuCallback;
WndClass.hInstance := HInstance;
{Windows.}{$IFDEF UNICODE_CTRLS}RegisterClassW{$ELSE}RegisterClassA{$ENDIF}(WndClass);
Result := {$IFDEF UNICODE_CTRLS}CreateWindowW{$ELSE}CreateWindowA{$ENDIF}
(IcmCallbackWnd, IcmCallbackWnd, WS_POPUPWINDOW, 0, 0, 0, 0, 0, 0,
HInstance, Pointer(ContextMenu));
end;

procedure GetProperties(Paths : {$IFDEF UNICODE_CTRLS}PWStrList{$ELSE}PStrList{$ENDIF}; MousePoint: TPoint; WC: HWND);
var
CoInit, AResult: HRESULT;
CommonDir, FileName: KOLString;
Desktop, ShellFolder: IShellFolder;
pchEaten, Attr: Cardinal;
PathPIDL: PItemIDList;
FilePIDL: array of PItemIDList;
ShellContextMenu: HMenu;
ICMenu: IContextMenu;
ICMenu2: IContextMenu2;
PopupMenuResult: BOOL;
CMD: TCMInvokeCommandInfo;
M: IMAlloc;
ICmd: Integer;
CallbackWindow: HWND;

S : KOLString;
i : integer;
begin
// Первичная инициализация
ShellContextMenu := 0;
Attr := 0;
PathPIDL := nil;
CallbackWindow := 0;
CoInit := CoInitialize{Ex}(nil);//, COINIT_MULTITHREADED);
try
// Получаем пути и имя фала
SetLength(FilePIDL, 0);
CommonDir := ExtractFilePath(Paths.Items[0]);
FileName := ExtractFileName(Paths.Items[0]);
// Получаем указатель на интерфейс рабочего стола
if SHGetDesktopFolder(Desktop) <> S_OK then
RaiseLastWin32Error;
// Если работаем с папкой
if FileName = "" then
begin
// Получаем указатель на папку "Мой компьютер"
if (SHGetSpecialFolderLocation(0, CSIDL_DRIVES, PathPIDL) <> S_OK) or
(Desktop.BindToObject(PathPIDL, nil, IID_IShellFolder,
Pointer(ShellFolder)) <> S_OK) then
RaiseLastWin32Error;

SetLength(FilePIDL, 1);
// Получаем указатель на директорию
if CommonDir <> "" then
if CommonDir[Length(CommonDir)] <> "\" then
CommonDir := CommonDir + "\";
ShellFolder.ParseDisplayName(WC, nil, StringToOleStr(CommonDir),
pchEaten, FilePIDL[0], Attr);
// Получаем указатель на контектсное меню папки
AResult := ShellFolder.GetUIObjectOf(WC, 1, FilePIDL[0],
IID_IContextMenu, nil, Pointer(ICMenu));
end
else
begin
// Получаем указатель на папку "Мой компьютер"
if (Desktop.ParseDisplayName(WC, nil, StringToOleStr(CommonDir), pchEaten, PathPIDL, Attr) <> S_OK) or
(Desktop.BindToObject(PathPIDL, nil, IID_IShellFolder, Pointer(ShellFolder)) <> S_OK) then
RaiseLastWin32Error;

for i := 0 to Paths.Count - 1 do
begin
S := ExtractFileName(Paths.Items[i]);
if S <> "" then
begin
SetLength(FilePIDL, i+1);
// Получаем указатель на файл
ShellFolder.ParseDisplayName(WC, nil, StringToOleStr(S), pchEaten,
FilePIDL[i], Attr);
// Получаем указатель на контектсное меню файла
end;
end;
AResult := ShellFolder.GetUIObjectOf(WC, Paths.Count, 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_CANRENAME or 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;

if ICmd = 18 then
//// Здесь код для пункта "Переименовать"
//// SendMessage(ListView.Handle, LVM_EDITLABEL, ListView.LVCurItem, 0)
else
begin
// Заполняем структуру TCMInvokeCommandInfo
FillChar(CMD, SizeOf(CMD), #0);
with CMD do
begin
cbSize := SizeOf(CMD);
hWND := WC;
lpVerb := MakeIntResourceA(ICmd);
nShow := SW_SHOWNORMAL;
end;
// Выполняем InvokeCommand с заполненной структурой
AResult := ICMenu.InvokeCommand(CMD);
if AResult <> S_OK then
RaiseLastWin32Error;
end;
SetForegroundWindow( Form.Handle);
end;
end;
finally
// Освобождаем занятые ресурсы чтобы небыло утечки памяти
if FilePIDL[0] <> nil then
begin
// Для освобождения использем IMalloc
SHGetMAlloc(M);
if M <> nil then
for i := 0 to Length(FilePIDL) - 1 do
M.Free(FilePIDL[i]);
M := nil;
SetLength(FilePIDL, 0);
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;
(*============================================================================*)

Вот так. Теперь думаю, эту тему и http://delphimaster.net/view/11-1190391967/ можно закрывать... Огромное спасибо Rouse_, non и mdw

Никак не могу разобраться с последним кодом. Правильно ли я делаю: я заменяю код в ExplorerMenu.pas на указанный выше,но при этом программа не запускается и не работает. Подскажите в чем моя ошибка. Не могу понять в чем дело. Как вывести меню для группы элементов, для этого надо как-то отделить файловые пути. А для этого надо использовать ";" или что?

> Как вывести меню для группы элементов, для этого надо как-то отделить файловые пути. А для этого надо использовать ";" или что?

procedure GetProperties(Paths : {$IFDEF UNICODE_CTRLS}PWStrList{$ELSE}PStrList{$ENDIF}; MousePoint: TPoint; WC: HWND);

В OnClick, заполняешь (W)StrList и передаешь в GetProperties.

Пришлось убрать:
SetForegroundWindow( Form.Handle);
CMF_CANRENAME
Из-за этого код не работал.
Обязательны ли эти пункты и каково должно быть значение
const CMF_CANRENAME.

> SetForegroundWindow( Form.Handle);

Это нет... Это от моего осталось.

> CMF_CANRENAME

В сист.меню появляется пункт "Переименовать" обрабатывается здесь:
if ICmd = 18 then //// Здесь код для пункта "Переименовать" //// SendMessage(ListView.Handle, LVM_EDITLABEL, ListView.LVCurItem, 0) else

Правильно ли я задал значение для const
CMF_CANRENAME = $00000010;
При этом значении пункт переименовать появляется.
Интересно, а каким образом можно добавить в такое меню свой пункт, например пункт добавить и т.п. ?
Возможно ли отобразить свойства файлов для двух дисков, только со вкладкой общие?

Добавить пункт к системному меню можно используя:
procedure TForm1.KOLForm1FormCreate(Sender: PObj);
begin
insertmenu(GetSystemMenu(Form.Handle, FALSE), 0, mf_string or mf_byposition, 0,"Действие");
insertmenu(GetSystemMenu(Form.Handle, FALSE), 1,mf_byposition or MF_SEPARATOR, 1,"");
end;

function TForm1.KOLForm1Message(var Msg: tagMSG;
var Rslt: Integer): Boolean;
begin
Result := FALSE;
if (Msg.message = WM_SYSCOMMAND)
and (Msg.hwnd = Form.Handle) then
begin
if Msg.wParam = 0 then
ShowMessage("Был нажат наш пункт меню!!!");
end;
end;
Взято: http://www.dotfix.net/module.php?module=@6e786b366a6a70736a6a5f7277705b685f676d
Но никак не получается обработать нажатие на добавленный пункт в ShellContextMenu.
Добавляю так:
Вставляю этот код в указанный выше.
// Показываем меню
insertmenu(ShellContextMenu, 0, mf_string or mf_byposition, 0,"Действие");
insertmenu(ShellContextMenu, 1,mf_byposition or MF_SEPARATOR, 1,"");
SetMenuDefaultItem(ShellContextMenu,0,0); //жирным шрифтом.
Подскажите пожалуйста, что я делаю не так? И точно также делаю обработку сообщения, но почему-то не работает.

Отображение системного контекстного меню эксплорера. Найти похожие ветки