How to select a Menu Item without closing the Menu?

Question

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

Answer 1

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

Answer 2

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.

Answer 3

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

Answer 4

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.