23

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.

  • 8
    +1. Within a few minutes, a lot of 'nitpickers' will argue that this is not the default Windows design, and that this will confuse the end user. However, to your defence, you can argue that the [status bar context menu](http://privat.rejbrand.se/officestatuscontext.png) in Microsoft Office (2010 at least) applications, to name only one example, behaves like this. And this is a very good thing, for this context menu contains only check-box items, and you are likely to click quite a few of them in a row. – Andreas Rejbrand May 12 '11 at 19:22
  • Well I dont have Office 2010, but looking from the screenshot in the link provided it appears to do something similar to what I want, the only difference being is I am using a standard TMainMenu. –  May 12 '11 at 19:30
  • I think that's going to be tough to achieve with a standard menu. – David Heffernan May 12 '11 at 19:47
  • 1
    @andreas you are often one of the chief nitpickers arguing in favour of standard UI. Have you reformed? ;-) – David Heffernan May 12 '11 at 19:48
  • @David: I know, but only to some extent. And this is one of the cases where a slighlty different design might be fully acceptable, as in the Microsoft Word case. – Andreas Rejbrand May 12 '11 at 19:50
  • It's acceptable yes, its not done using the Win32 builtin popup menu tracking functions. – Warren P May 12 '11 at 20:00
  • 1
    I wonder if the `TActionMainMenuBar` can be modified to achieve this (of course, only when the action manager's `Style <> Platform default` ). – Andreas Rejbrand May 12 '11 at 20:02
  • @Andreas: Yes it can, I've done that for one of my projects. Unfortunately, my particular implementation is a mixture of modified VCL code and a few of my own derived classes; I hesitate to publish it here. – Ondrej Kelle May 12 '11 at 21:05
  • Does [this](http://stackoverflow.com/questions/2766072/how-can-i-make-a-menu-stay-visible-after-its-clicked/2770088#2770088) make sense? – Sertac Akyuz May 12 '11 at 21:59
  • @Andreas using TActionMainMenuBar is not problem if a solution can be found using this, I sometimes use this component for Office XP style menu. My problem does not seem to have a straight forward answer however, so I am not hoping for too much. –  May 12 '11 at 21:59

4 Answers4

14

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.
Sertac Akyuz
  • 54,131
  • 4
  • 102
  • 169
  • excellent job, I have tested and this works perfect with popupmenu. I will check out the link you posted to see if I can adapt for main menu. Your answer has been accepted thanks. –  May 13 '11 at 09:11
  • @Craig, thanks, and you're welcome! The answer I referred in the comment is rather relevant with popups that are launching automatically ('PopupMenu' property of controls), and also mentions few things which are ignored in this answer, like sub-menus, accelerator keys (more work to do..). Possibly you'll have to think of some other special cases as well, f.i. disabled items.. I believe main menu handling would be similar to this answer because menu messages are sent to the form.. – Sertac Akyuz May 13 '11 at 11:17
  • nice answer and +1. I [posted a question](http://stackoverflow.com/questions/14182307/checking-unchecking-tmenuitem-without-closing-the-tpopupmenu) which turned to be a duplicate. but there is a small problem with your code: if I set `Item.Checked := not Item.Checked` right after `Item.Click;` (MenuSelectID) - The Item is not invalidated, and the check is not drawn until I leave the Item area and Enter back to it :( What can be done? – ZigiZ Jan 06 '13 at 15:46
  • 3
    Adding `InvalidateRect(FPopupWindowHandle, nil, False);` after that fixed it... :) – ZigiZ Jan 06 '13 at 16:15
  • @ZigZ - Glad you've resolved it, I don't quite remember what I've done here :) .. and thanks for the vote. :) – Sertac Akyuz Jan 06 '13 at 17:12
  • @SertacAkyuz Does this work for you on 64bit executable? I have had problems with the code below tha was based on yours. My testing shows it work for me with 32bit-executable on XP32bit and Win1064bit but fails for 64bit-executable. I don't know why yet, but you can expose the problem by clicking outside the menu (so seems to happen when menu is about to close / closes) - just checking if anyone else encountered and solved this? I suspect it could be related to 32>64bit message handling code. – Tom Mar 27 '18 at 21:44
  • @Tom - I've never tested before. Initially I've wrote it with D2007. I now tested this with XE2, 64 bit target on W7x64, there was no problem. I don't have Windows 10 to test sorry, but looks like bitness may not be the problem. – Sertac Akyuz Mar 27 '18 at 22:56
  • I did notice though that when you click in quick succession on an item, it is closed. That is because the item receives a MN_DBLCLK. Include that also in the popup window proc: `const MN_DBLCLK = $01F1;` `... case Msg.Msg of MN_BUTTONDOWN, MN_DBLCLK: ...` – Sertac Akyuz Mar 27 '18 at 22:58
  • @SertacAkyuz Thank you - I will try research it more today if I can figure out what is happening – Tom Mar 28 '18 at 06:48
11

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

kobik
  • 21,001
  • 4
  • 61
  • 121
  • Thanks, man, you saved a lot of my time. Many pluses to your karma! – Denys Avilov Apr 22 '16 at 18:34
  • @kobik Does not work for me on 64bit executables. Works: 32executable on XP32bit and Win1064bit. Fails: 64executable. I don't know why yet, but you can expose the problems by clicking outside the menu (so seems to happen when menu is about to close / closes) – Tom Mar 27 '18 at 21:38
  • More precisely you get by popup menu (I do from a toolbar) - then click anywhere outside menu (which normally closes menu) - and I get error $C0000005 access violation. But seems to happen inside Windows - Delphi callstack wont show exactly where except it happens inside Popup InstallMenuCallWndHook – Tom Mar 28 '18 at 09:03
  • @Tom, Sorry I don't have a 64bit compiler to test. I would suspect `GetWindowLong` should be replaced with `GetWindowLongPtr` etc... – kobik Mar 28 '18 at 10:25
  • @kobik Fixing those does not seem to be enough - but yes - it is probably a 32/64bit issue. I will return when/if I get more info. – Tom Mar 29 '18 at 16:41
  • If anyone else makes progress on this please add comments – Tom Jul 27 '20 at 09:51
4

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.

Warren P
  • 65,725
  • 40
  • 181
  • 316
  • a few very good suggestions there. The panel/form idea is probably not feasible however, especially since it would mean alot of work maintaining it (items, images etc). I dont have the DevExpress component suite which I know you have to pay for. –  May 12 '11 at 22:02
  • If anyone knows of other who gone through the task of initializing a custom form with information found in menus (e.g. for controlling 50+ columns visibility) ... the popup menu contains enough information that it should be possible to create a generalized custom popupmenu form replacement re-creating menus ... But quite a bit of work still – Tom Jul 10 '20 at 10:46
2

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

RobertFrank
  • 7,332
  • 11
  • 53
  • 99