Текущий архив: 2008.07.27;
Скачать: CL | DM;

Вниз

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

← →
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

---

← →
Nikfel ©   (2007-10-01 11:20) [15]

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

---

← →
MTsv DN ©   (2007-10-01 14:11) [16]

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

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

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

---

← →
Nikfel ©   (2007-10-01 18:58) [17]

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

---

← →
MTsv DN ©   (2007-10-01 20:28) [18]

> SetForegroundWindow( Form.Handle);

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


> CMF_CANRENAME

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

---

← →
Nikfel ©   (2007-10-02 10:07) [19]

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

---

← →
Nikfel ©   (2007-10-11 19:59) [20]

Добавить пункт к системному меню можно используя:
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); //жирным шрифтом.
Подскажите пожалуйста, что я делаю не так? И точно также делаю обработку сообщения, но почему-то не работает.

---

Страницы: 1 вся ветка

Текущий архив: 2008.07.27;
Скачать: CL | DM;

Наверх

Память: 0.64 MB
Время: 0.008 c