Reputation:
By default when you select an item from a TMainMenu or TPopupMenu etc, the menu closes after it was clicked. I would like to change this behavior so that when I select on a menu item, the menu does not close but remains visible and open at the point it was last clicked, making it easier to select another menu item if desired. Of course, switching focus to another control should hide the menu like normal, but if the focus is still on the menu keep it visible.
If this is possible, I would like this behavior to only work on specified menu items. In other words, if I can make all the menu items work like normal, but if I specify one or two menu items, these will not close the menu when selected.
The reason I want to do this is like so, I have a Preferences form in my Application where many options can be configured, the usual stuff etc, but also in the Main Form I have some of the common more frequent used options set in a TMainMenu. These common options in my menu I would like to be able to select without closing the menu, so that other options can be selected for example without having to navigate through the menu items.
Is there a standardized way of achieving this?
Thanks
Craig.
Upvotes: 23
Views: 9250
Reputation: 21242
Based on @Sertac's code and other resources, I have made a small unit which makes an Interposer class of TPopupMenu
and TMainMenu
(also for TNT versions).
It handles sub-menus also (each time a sub-menu is activated, a new menu window is created with new menu handle).
The idea was to create an application-defined hook (WH_CALLWNDPROC
) with a lifetime as short as possible. The hook will be active only as long as the menu modal loop is active. Once the hook detects a new Popup window handle (via WM_ENTERIDLE
), it then subclasses it until it is destroyed.
{.$DEFINE TNT}
unit AppTrackMenus;
interface
uses
Windows, Messages, SysUtils, Classes, Controls, Forms, Contnrs, Menus
{$IFDEF TNT}, TntMenus{$ENDIF};
type
TTrackMenuNotifyEvent = procedure(Sender: TMenu; Item: TMenuItem; var CanClose: Boolean) of object;
TPopupMenu = class(Menus.TPopupMenu)
private
FTrackMenu: Boolean;
FOnTrackMenuNotify: TTrackMenuNotifyEvent;
public
procedure Popup(X, Y: Integer); override;
property TrackMenu: Boolean read FTrackMenu write FTrackMenu;
property OnTrackMenuNotify: TTrackMenuNotifyEvent read FOnTrackMenuNotify write FOnTrackMenuNotify;
end;
{$IFDEF TNT}
TTntPopupMenu = class(TntMenus.TTntPopupMenu)
private
FTrackMenu: Boolean;
FOnTrackMenuNotify: TTrackMenuNotifyEvent;
public
procedure Popup(X, Y: Integer); override;
property TrackMenu: Boolean read FTrackMenu write FTrackMenu;
property OnTrackMenuNotify: TTrackMenuNotifyEvent read FOnTrackMenuNotify write FOnTrackMenuNotify;
end;
{$ENDIF}
TMainMenu = class(Menus.TMainMenu)
private
FTrackMenu: Boolean;
FOnTrackMenuNotify: TTrackMenuNotifyEvent;
public
property TrackMenu: Boolean read FTrackMenu write FTrackMenu;
property OnTrackMenuNotify: TTrackMenuNotifyEvent read FOnTrackMenuNotify write FOnTrackMenuNotify;
end;
{$IFDEF TNT}
TTntMainMenu = class(TntMenus.TTntMainMenu)
private
FTrackMenu: Boolean;
FOnTrackMenuNotify: TTrackMenuNotifyEvent;
public
property Hook: Boolean read FTrackMenu write FTrackMenu;
property OnTrackMenuNotify: TTrackMenuNotifyEvent read FOnTrackMenuNotify write FOnTrackMenuNotify;
end;
{$ENDIF}
procedure FormMainMenuWndProcMessage(var Msg: TMessage; AForm: TCustomForm);
implementation
const
{ Undocumented Menu Messages }
MN_SETHMENU = $01E0;
MN_GETHMENU = $01E1;
MN_SIZEWINDOW = $01E2;
MN_OPENHIERARCHY = $01E3;
MN_CLOSEHIERARCHY = $01E4;
MN_SELECTITEM = $01E5;
MN_CANCELMENUS = $01E6;
MN_SELECTFIRSTVALIDITEM = $01E7;
MN_GETPPOPUPMENU = $01EA;
MN_FINDMENUWINDOWFROMPOINT = $01EB;
MN_SHOWPOPUPWINDOW = $01EC;
MN_BUTTONDOWN = $01ED;
MN_MOUSEMOVE = $01EE;
MN_BUTTONUP = $01EF;
MN_SETTIMERTOOPENHIERARCHY = $01F0;
MN_DBLCLK = $01F1;
var
ActiveHookMenu: TMenu = nil;
type
TPopupWndList = class;
TPopupWnd = class
private
FHandle: THandle;
FMenuHandle: HMENU;
FOrgPopupWindowProc, FHookedPopupWindowProc: Pointer;
FSelectedItemPos: Integer;
FSelectedItemID: UINT;
FHooked: Boolean;
FPopupWndList: TPopupWndList;
function GetHMenu: HMENU;
procedure PopupWindowProc(var Msg: TMessage);
procedure Hook;
procedure UnHook;
procedure MenuSelectPos(Menu: TMenu; ItemPos: UINT; out CanClose: Boolean);
procedure MenuSelectID(Menu: TMenu; ItemID: UINT; out CanClose: Boolean);
public
property Handle: THandle read FHandle write FHandle;
property MenuHandle: HMENU read FMenuHandle;
constructor Create(APopupWndList: TPopupWndList; AHandle: THandle); overload;
destructor Destroy; override;
end;
TPopupWndList = class(TObjectList)
public
function FindHookedPopupHWnd(MenuWindow: HWND): TPopupWnd;
function FindHookedPopupHMenu(Menu: HMENU): TPopupWnd;
end;
{ TPopupWnd }
constructor TPopupWnd.Create(APopupWndList: TPopupWndList; AHandle: THandle);
begin
inherited Create;
FHandle := AHandle;
FMenuHandle := GetHMenu;
FPopupWndList := APopupWndList;
Hook;
end;
destructor TPopupWnd.Destroy;
begin
if FHooked then // JIC: normally UnHook is called in PopupWindowProc WM_DESTROY
UnHook;
inherited;
end;
procedure TPopupWnd.Hook;
begin
FOrgPopupWindowProc := Pointer(GetWindowLong(FHandle, GWL_WNDPROC));
FHookedPopupWindowProc := MakeObjectInstance(PopupWindowProc);
SetWindowLong(FHandle, GWL_WNDPROC, Longint(FHookedPopupWindowProc));
FHooked := True;
end;
procedure TPopupWnd.UnHook;
begin
SetWindowLong(FHandle, GWL_WNDPROC, Longint(FOrgPopupWindowProc));
FreeObjectInstance(FHookedPopupWindowProc);
FHooked := False;
end;
procedure TPopupWnd.PopupWindowProc(var Msg: TMessage);
var
NormalItem: Boolean;
begin
case Msg.Msg of
MN_SELECTITEM:
begin
// -1 ($FFFF) => mouse is outside the menu window
FSelectedItemPos := Integer(Msg.wParam); // HiWord(Msg.wParam)
end;
MN_DBLCLK:
begin
Exit; // eat
end;
MN_BUTTONDOWN:
begin
MenuSelectPos(ActiveHookMenu, UINT(Msg.WParamLo), NormalItem);
if not NormalItem then
Exit;
end;
WM_KEYDOWN:
if (Msg.WParam = VK_RETURN) and (FSelectedItemPos <> -1) and (FSelectedItemID <> 0) then begin
MenuSelectID(ActiveHookMenu, FSelectedItemID, NormalItem);
if not NormalItem then
Exit;
end;
WM_DESTROY:
begin
UnHook;
end;
end;
Msg.Result := CallWindowProc(FOrgPopupWindowProc, FHandle, Msg.Msg, Msg.WParam, Msg.LParam);
end;
procedure TPopupWnd.MenuSelectPos(Menu: TMenu; ItemPos: UINT; out CanClose: Boolean);
begin
MenuSelectID(Menu, GetMenuItemID(GetHMenu, ItemPos), CanClose);
end;
function GetMenuItemPos(Menu: HMENU; ItemID: UINT): Integer;
var
I: Integer;
MenuItemInfo: TMenuItemInfo;
begin
Result := -1;
if IsMenu(Menu) then
for I := 0 to GetMenuItemCount(Menu) do
begin
FillChar(MenuItemInfo, SizeOf(MenuItemInfo), 0);
MenuItemInfo.cbSize := SizeOf(MenuItemInfo);
MenuItemInfo.fMask := MIIM_ID;
if (GetMenuItemInfo(Menu, I, True, MenuItemInfo)) then
if MenuItemInfo.wID = ItemID then
begin
Result := I;
Exit;
end;
end;
end;
procedure TPopupWnd.MenuSelectID(Menu: TMenu; ItemID: UINT; out CanClose: Boolean);
var
Item: TMenuItem;
NotifyEvent: TTrackMenuNotifyEvent;
R: TRect;
begin
CanClose := True;
Item := Menu.FindItem(ItemID, fkCommand);
if Assigned(Item) then
begin
NotifyEvent := nil;
{$IFDEF TNT}
if Menu is TTntPopupMenu then
NotifyEvent := TTntPopupMenu(Menu).FOnTrackMenuNotify
else
{$ENDIF}
if Menu is TPopupMenu then
NotifyEvent := TPopupMenu(Menu).FOnTrackMenuNotify
else
{$IFDEF TNT}
if Menu is TTntMainMenu then
NotifyEvent := TTntMainMenu(Menu).FOnTrackMenuNotify
else
{$ENDIF}
if Menu is TMainMenu then
NotifyEvent := TMainMenu(Menu).FOnTrackMenuNotify;
if Assigned(NotifyEvent) then
NotifyEvent(Menu, Item, CanClose);
if not CanClose then
begin
Item.Click;
if GetMenuItemRect(FHandle, FMenuHandle, GetMenuItemPos(FMenuHandle, ItemID), R) then
begin
MapWindowPoints(0, FHandle, R, 2);
InvalidateRect(FHandle, @R, False);
end else
InvalidateRect(FHandle, nil, False);
end;
end;
end;
function TPopupWnd.GetHMenu: HMENU;
begin
Result := SendMessage(FHandle, MN_GETHMENU, 0, 0);
end;
{ TPopupWndList }
function TPopupWndList.FindHookedPopupHWnd(MenuWindow: HWND): TPopupWnd;
var
I: Integer;
PopupWnd: TPopupWnd;
begin
Result := nil;
for I := 0 to Count - 1 do
begin
PopupWnd := TPopupWnd(Items[I]);
if (PopupWnd.FHooked) and (PopupWnd.Handle = MenuWindow) then
begin
Result := PopupWnd;
Exit;
end;
end;
end;
function TPopupWndList.FindHookedPopupHMenu(Menu: HMENU): TPopupWnd;
var
I: Integer;
PopupWnd: TPopupWnd;
begin
Result := nil;
for I := 0 to Count - 1 do
begin
PopupWnd := TPopupWnd(Items[I]);
if (PopupWnd.FHooked) and (PopupWnd.MenuHandle{GetHMenu} = Menu) then
begin
Result := PopupWnd;
Exit;
end;
end;
end;
var
PopupWndList: TPopupWndList = nil;
MenuCallWndHook: HHOOK = 0;
SelectedItemID: UINT = 0;
NeedPopupWindowHandle: Boolean = False;
InitMenuPopupCount: Integer = 0;
function CallWndHookProc(nCode: Integer; wParam: WPARAM; Msg: PCWPStruct): LRESULT; stdcall;
var
Menu: HMENU;
MenuWnd: HWND;
PopupWnd: TPopupWnd;
begin
if (nCode = HC_ACTION) then
begin
case Msg.message of
WM_INITMENUPOPUP:
begin // TWMInitMenuPopup
Inc(InitMenuPopupCount);
NeedPopupWindowHandle := True;
SelectedItemID := 0;
if PopupWndList = nil then
begin
PopupWndList := TPopupWndList.Create(True); // OwnsObjects
end;
end;
WM_UNINITMENUPOPUP:
begin
Dec(InitMenuPopupCount);
end;
WM_ENTERIDLE:
begin
if (Msg.wParam = MSGF_MENU) and NeedPopupWindowHandle then
begin
NeedPopupWindowHandle := False;
MenuWnd := HWND(Msg.lParam);
if Assigned(PopupWndList) and (PopupWndList.FindHookedPopupHWnd(MenuWnd) = nil) then
PopupWndList.Add(TPopupWnd.Create(PopupWndList, MenuWnd));
end;
end;
WM_MENUSELECT:
begin
// MSDN: If the high-order word of wParam contains 0xFFFF and the lParam parameter contains NULL, the system has closed the menu.
if (Msg.lParam = 0) and (HiWord(Msg.wParam) = $FFFF) then // Menu Closed
begin
FreeAndNil(PopupWndList);
end
else
begin
Menu := HMENU(Msg.lParam);
if HiWord(Msg.wParam) and MF_POPUP <> 0 then // fkHandle
SelectedItemID := GetSubMenu(Menu, LoWord(Msg.WParam))
else // fkCommand
SelectedItemID := LoWord(Msg.wParam); // TWMMenuSelect(Msg).IDItem;
if Assigned(PopupWndList) then
begin
PopupWnd := PopupWndList.FindHookedPopupHMenu(Menu);
if Assigned(PopupWnd) then
begin
PopupWnd.FSelectedItemID := LoWord(Msg.wParam);
end;
end;
end;
end;
end;
end;
Result := CallNextHookEx(MenuCallWndHook, nCode, WParam, Longint(Msg));
end;
procedure InstallMenuCallWndHook(Menu: TMenu);
begin
ActiveHookMenu := Menu;
MenuCallWndHook := SetWindowsHookEx(WH_CALLWNDPROC, @CallWndHookProc, 0, GetCurrentThreadId);
end;
procedure UnInstallMenuCallWndHook;
begin
if MenuCallWndHook <> 0 then
UnHookWindowsHookEx(MenuCallWndHook);
MenuCallWndHook := 0;
ActiveHookMenu := nil;
PopupWndList := nil;
end;
{ TPopupMenu }
procedure TPopupMenu.Popup(X, Y: Integer);
begin
if not FTrackMenu then
inherited
else
try
InstallMenuCallWndHook(Self);
inherited;
finally
UnInstallMenuCallWndHook;
end;
end;
{ TTntPopupMenu }
{$IFDEF TNT}
procedure TTntPopupMenu.Popup(X, Y: Integer);
begin
if not FTrackMenu then
inherited
else
try
InstallMenuCallWndHook(Self);
inherited;
finally
UnInstallMenuCallWndHook;
end;
end;
{$ENDIF}
function GetMenuForm(Menu: TMenu): TCustomForm;
var
LForm: TWinControl;
begin
Result := nil;
if Menu.WindowHandle <> 0 then
begin
LForm := FindControl(Menu.WindowHandle);
if (LForm <> nil) and (LForm is TCustomForm) then
Result := LForm as TCustomForm;
end;
end;
function FormMainMenuIsValid(AForm: TCustomForm): Boolean;
begin
Result := False;
if Assigned(AForm) and Assigned(AForm.Menu) then
begin
{$IFDEF TNT}
if (AForm.Menu is TTntMainMenu) then
Result := TTntMainMenu(AForm.Menu).FTrackMenu
else
{$ENDIF}
if (AForm.Menu is TMainMenu) then
Result := TMainMenu(AForm.Menu).FTrackMenu;
end;
end;
procedure FormMainMenuWndProcMessage(var Msg: TMessage; AForm: TCustomForm);
begin
if not FormMainMenuIsValid(AForm) then
Exit;
case Msg.Msg of
WM_INITMENU:
begin
// MSDN: Sent when a menu is about to become active. It occurs when the user clicks an item on the menu bar or presses a menu key.
// A window receives this message through its WindowProc function
// A WM_INITMENU message is sent only when a menu is first accessed; only one WM_INITMENU message is generated for each access.
// For example, moving the mouse across several menu items while holding down the button does not generate new messages
InstallMenuCallWndHook(AForm.Menu);
end;
WM_MENUSELECT:
begin
// MSDN: If the high-order word of wParam contains 0xFFFF and the lParam parameter contains NULL, the system has closed the menu.
if (Msg.lParam = 0) and (HiWord(Msg.wParam) = $FFFF) then // Menu Closed
begin
UnInstallMenuCallWndHook;
end;
end;
end;
end;
end.
Usage:
Drop a TPopupMenu
and/or TMainMenu
on the form. in the uses
include AppTrackMenus
after Menus
. Create some menu items and for each menu item you want to not be closed when clicked, set Tag
=666 (for this example). You can assign each of these items an OnClick
event handler CheckNoCloseClick
.
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Menus, AppTrackMenus;
TForm1 = class(TForm)
...
procedure CheckNoCloseClick(Sender: TObject);
protected
procedure WndProc(var Msg: TMessage); override; // for TMainMenu
private
procedure TrackMenuNotifyHandler(Sender: TMenu; Item: TMenuItem; var CanClose: Boolean);
end;
implementation
procedure TForm1.FormCreate(Sender: TObject);
begin
PopupMenu1.TrackMenu := True;
PopupMenu1.OnTrackMenuNotify := TrackMenuNotifyHandler;
MainMenu1.TrackMenu := True;
MainMenu1.OnTrackMenuNotify := TrackMenuNotifyHandler;
end;
procedure TForm1.CheckNoCloseClick(Sender: TObject);
begin
TMenuItem(Sender).Checked := not TMenuItem(Sender).Checked;
end;
procedure TForm1.TrackMenuNotifyHandler(Sender: TMenu; Item: TMenuItem; var CanClose: Boolean);
begin
Caption := Sender.ClassName + '-' + Item.ClassName + '-' + Item.Name;
CanClose := Item.Tag <> 666;
end;
procedure TForm1.WndProc(var Msg: TMessage); // for TMainMenu
begin
FormMainMenuWndProcMessage(Msg, Self);
inherited;
end;
The TMainMenu
Interposer could be improved by sub-classing it's Form at run time, on demand (by setting a new Form.WindowProc
) without the need of overriding WndProc
for each Form. But ,there is usually only one main menu per application. Maybe next version... :)
Tested in XP/Vista/Win7
Upvotes: 11
Reputation: 54802
In the below code, when right clicked on the panel on the form, a popup menu with three items is launched. The first item behaves normally, the other two items also fires their click events but the popup menu is not closed.
The popup is launched with 'TrackPopupMenu', if instead you'd like to use 'OnPopup' events, or need to use sub menus having non-closing items, refer to the link in the comment I posted to your question. Adapting the code for a main menu would not be difficult as well..
I'm not commenting the code not to promote the usage of the approach since it makes use of an undocumented message, also I feel it is a bit convoluted..
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, Menus, ExtCtrls;
type
TForm1 = class(TForm)
PopupMenu1: TPopupMenu;
Item1Normal1: TMenuItem;
Item2NoClose1: TMenuItem;
Item3NoClose1: TMenuItem;
Panel1: TPanel;
procedure Panel1ContextPopup(Sender: TObject; MousePos: TPoint;
var Handled: Boolean);
private
FGetPopupWindowHandle: Boolean;
FPopupWindowHandle: HWND;
OrgPopupWindowProc, HookedPopupWindowProc: Pointer;
FSelectedItemID: UINT;
procedure WmInitMenuPopup(var Msg: TWMInitMenuPopup); message WM_INITMENUPOPUP;
procedure WmEnterIdle(var Msg: TWMEnterIdle); message WM_ENTERIDLE;
procedure WmMenuSelect(var Msg: TWMMenuSelect); message WM_MENUSELECT;
procedure PopupWindowProc(var Msg: TMessage);
procedure MenuSelectPos(Menu: TMenu; ItemPos: UINT; out CanClose: Boolean);
procedure MenuSelectID(Menu: TMenu; ItemID: UINT; out CanClose: Boolean);
public
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.Panel1ContextPopup(Sender: TObject; MousePos: TPoint;
var Handled: Boolean);
var
Pt: TPoint;
begin
Pt := (Sender as TPanel).ClientToScreen(MousePos);
TrackPopupMenu(PopupMenu1.Handle, 0, Pt.X, Pt.Y, 0, Handle, nil);
end;
procedure TForm1.WmInitMenuPopup(var Msg: TWMInitMenuPopup);
begin
inherited;
if Msg.MenuPopup = PopupMenu1.Handle then
FGetPopupWindowHandle := True;
end;
procedure TForm1.WmEnterIdle(var Msg: TWMEnterIdle);
begin
inherited;
if FGetPopupWindowHandle then begin
FGetPopupWindowHandle := False;
FPopupWindowHandle := Msg.IdleWnd;
HookedPopupWindowProc := classes.MakeObjectInstance(PopupWindowProc);
OrgPopupWindowProc := Pointer(GetWindowLong(FPopupWindowHandle, GWL_WNDPROC));
SetWindowLong(FPopupWindowHandle, GWL_WNDPROC, Longint(HookedPopupWindowProc));
end;
end;
procedure TForm1.WmMenuSelect(var Msg: TWMMenuSelect);
begin
inherited;
if Msg.Menu = PopupMenu1.Handle then
FSelectedItemID := Msg.IDItem;
end;
const
MN_BUTTONDOWN = $01ED;
procedure TForm1.PopupWindowProc(var Msg: TMessage);
var
NormalItem: Boolean;
begin
case Msg.Msg of
MN_BUTTONDOWN:
begin
MenuSelectPos(PopupMenu1, UINT(Msg.WParamLo), NormalItem);
if not NormalItem then
Exit;
end;
WM_KEYDOWN:
if Msg.WParam = VK_RETURN then begin
MenuSelectID(PopupMenu1, FSelectedItemID, NormalItem);
if not NormalItem then
Exit;
end;
WM_DESTROY:
begin
SetWindowLong(FPopupWindowHandle, GWL_WNDPROC, Longint(OrgPopupWindowProc));
classes.FreeObjectInstance(HookedPopupWindowProc);
end;
end;
Msg.Result := CallWindowProc(OrgPopupWindowProc, FPopupWindowHandle,
Msg.Msg, Msg.WParam, Msg.LParam);
end;
procedure TForm1.MenuSelectID(Menu: TMenu; ItemID: UINT; out CanClose: Boolean);
var
Item: TMenuItem;
begin
CanClose := True;
Item := Menu.FindItem(ItemID, fkCommand);
if Assigned(Item) then begin
// Menu Item is clicked
Item.Click;
// Panel1.Caption := Item.Name;
CanClose := Item = Item1Normal1;
end;
end;
procedure TForm1.MenuSelectPos(Menu: TMenu; ItemPos: UINT; out CanClose: Boolean);
begin
MenuSelectID(Menu, GetMenuItemID(Menu.Handle, ItemPos), CanClose);
end;
end.
Upvotes: 14
Reputation: 7394
I had the same need recently and found that TMS Smooth controls has "tear off" menus which has a similar function but require (as indicated by the name) that the menu be, um, torn off! I never looked into to, because my need wasn't strong enough to justify the time, money, or use of a third party product. But, I've used other stuff of theirs that has been first rate.
Not sure if their tear off menus would fill your needs, but you might want to look into it.
http://www.tmssoftware.com/site/advsmoothmegamenu.asp
Upvotes: 2
Reputation: 68892
My guess is that although this is acceptable, you should probably consider writing your own menu system, using Panels or forms, or a complete custom control/component set, and not use the standard TPopupMenu or TMainMenu at all if you want to do this.
If you want some starter source code, I would start with something like the Toolbar2000+SpTBX Sources. I am pretty sure you would be able to accomplish this using those, but not with TMainMenu and TPopupMenu, because they wrap some Win32 builtins that will have behaviours (including closing when you don't want to) that it's not possible to override.
You might also be able to do something like this out of the box with the Developer Express toolbar components.
Upvotes: 4