Display a ToolTip hint on a disabled menu item of a popup menu

Question

So I have a TMenuItem attached to a TAction on a TPopupMenu for a TDBGrid (actually 3rd party, but you get the idea). Based on the selected row in the grid, the TAction is enabled or disabled. What I want is to be able to display a hint to the user explaining why the item is disabled.

As far as why I want a hint on a disabled menu item, lets just say I am in agreement with Joel.

All TMenuItem's have a hint property, but as best I can tell they are only used the the TApplicationEvent.OnHint event handler to stick the hint in a TStatusBar or some other special processing. I found an article on how to create your own even window for a TMainMenu's TMenuItems, but it doesn't work on a TPopupMenu's TMenuItem. It works by handling the WM_MENUSELECT message, which as far as I can tell is not sent on a TPopupMenu.

Answer 1

A couple years ago I packed this nice solution in TForm-derived class, which you can use instead of Tform to enjoy hints in all your popup menus:

unit UnitMenu;

interface

uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes,     Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.Menus, Vcl.StdCtrls,VCL.ExtCtrls,     Vcl.AppEvnts;
//  menuHint;

type

{│}   TMenuItemHint = class(THintWindow)
{│}     private
{│}       activeMenuItem : TMenuItem;
{│}       showTimer : TTimer;
{│}       hideTimer : TTimer;
{│}       procedure HideTime(Sender : TObject) ;
{│}       procedure ShowTime(Sender : TObject) ;
{│}     public
{│}       constructor Create(AOwner : TComponent) ; override;
{│}       destructor Destroy; override;
{│}       procedure DoActivateHint(menuItem : TMenuItem) ;
{│}    end;

  TFormMenuHint = class(TForm)
    ApplicationEventsMenu: TApplicationEvents;
    procedure ApplicationEventsMenuHint(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    { Private declarations }
    //menuhint members
{│} miHint : TMenuItemHint;
{│} fOldWndProc: TFarProc;
    procedure PopupListWndProc(var AMsg: TMessage);
  public
    { Public declarations }
  end;

var
  Form8: TFormMenuHint;

implementation

{$R *.dfm}
{│} procedure TMenuItemHint.HideTime(Sender: TObject);
{│} begin
{│}    //hide (destroy) hint window
{│}    self.ReleaseHandle;
   if assigned(hidetimer) then
   begin
{│}     hideTimer.OnTimer := nil;
    freeandnil(hidetimer);
   end;
{│} end;
{│} procedure TMenuItemHint.ShowTime(Sender: TObject);
{│}
{│}   procedure Split(Delim: Char; Str: string; Lst: TStrings) ;
{│}   begin
{│}      Lst.Clear;
{│}      Lst.StrictDelimiter := True;
{│}      Lst.Delimiter     := Delim;
{│}      Lst.DelimitedText := Str;
{│}   end;
{│}
{│} var
{│}   r : TRect;
{│}   wdth : integer;
{│}   list : TStringList;
{│}   s,str  : string;
{│}   j,h,w : integer;
{│}
{│} begin
{│}   if activeMenuItem <> nil then
{│}   begin
{│}      str := activeMenuItem.Hint;
{│}      str := StringReplace(str,#13#10,'|',[rfReplaceAll]);
{│}      str := StringReplace(str,#13,'|',[rfReplaceAll]);
{│}      str := StringReplace(str,#10,'|',[rfReplaceAll]);
{│}      while AnsiPos('||',str) > 0 do
{│}      begin
{│}        str := StringReplace(str,'||','|',[]);
{│}      end;
{│}
{│}      list := TStringList.Create;
{│}      split('|',str,list);
{│}      s := '';
{│}      h := Canvas.TextHeight(str) * (list.Count);
{│}      w := 0;
{│}      for j := 0 to list.Count -1 do
{│}      begin
{│}        if j > 0 then s := s + #13#10;
{│}        s := s + list[j];
{│}        wdth := Canvas.TextWidth(list[j]);
{│}        if wdth > w then w := wdth;
{│}      end;
{│}      list.Free;
{│}
{│}     //position and resize
{│}     r.Left := Mouse.CursorPos.X;
{│}     r.Top := Mouse.CursorPos.Y + 20;
{│}     r.Right := r.Left + w + 8;
{│}     r.Bottom := r.Top + h + 2;//6;
{│}     ActivateHint(r,s);
{│}   end;
{│}
{│}   showTimer.OnTimer := nil;
  hideTimer := TTimer.Create(self) ;
  hideTimer.OnTimer := HideTime;
  hidetimer.Interval:=50*length(s);
{│} end; (*ShowTime*)
{├─────────────────────────────────────────────────────────────}
{│} constructor TMenuItemHint.Create(AOwner: TComponent);
{│} begin
{│}   inherited;
{│}   showTimer := TTimer.Create(self) ;
{│}   showTimer.Interval := Application.HintPause;
{│}
{│}//   hideTimer := TTimer.Create(self) ;
{│}//   hideTimer.Interval := Application.HintHidePause;
{│} end;
{├─────────────────────────────────────────────────────────────}
{│} destructor TMenuItemHint.Destroy;
{│} begin
{│}   hidetimer.free;//hideTimer.OnTimer := nil;
{│}   showTimer.free;//showTimer.OnTimer := nil;
{│}   self.ReleaseHandle;
{│}   inherited;
{│} end;
{├─────────────────────────────────────────────────────────────}
{│} procedure TMenuItemHint.DoActivateHint(menuItem: TMenuItem);
{│} begin
{│}   //force remove of the "old" hint window
{│}   hideTime(self) ;
{│}
{│}   if (menuItem = nil) or (menuItem.Hint = '') then
{│}   begin
{│}     activeMenuItem := nil;
{│}     Exit;
{│}   end;
{│}
{│}   activeMenuItem := menuItem;
{│}
{│}   showTimer.OnTimer := ShowTime;
{│}   //hideTimer.OnTimer := HideTime;
{│} end;
{├────────────────────────────────────────────────────────────┐}

{│} procedure TFormMenuHint.ApplicationEventsMenuHint(Sender: TObject);
var
 ms:Tpoint;
 mitem,i:integer;
 NewWndProc: TFarProc;
 popupmenu:Tpopupmenu;
begin
 getcursorpos(ms);
 mitem:=-1;
 for i:=0 to ComponentCount-1 do
  if components[i] is Tpopupmenu then begin
    popupmenu:=Tpopupmenu(components[i]);
    mitem:=MenuItemFromPoint(0,Tpopupmenu(components[i]).Handle,ms);
    if mitem>=0 then
     break;
  end;
 if mitem<0 then
    exit;
 if not assigned(miHint) then begin
   mihint:=Tmenuitemhint.create(self);
   NewWndProc := MakeObjectInstance(PopupListWndProc);
   fOldWndProc := TFarProc(SetWindowLong(VCL.Menus.PopupList.Window, GWL_WNDPROC,
        nativeint(NewWndProc))); //11.3
 end;
 miHint.DoActivateHint(popupmenu.items[mItem]);
end;

procedure TFormMenuHint.FormDestroy(Sender: TObject);
{│} var
{│}   NewWndProc: TFarProc;
{│} begin
  if not assigned(mihint) then  exit;
{│}   NewWndProc := TFarProc(SetWindowLong(VCL.Menus.PopupList.Window, GWL_WNDPROC,
         nativeint(fOldWndProc))); //11.3
{│}   FreeObjectInstance(NewWndProc);
  freeandnil(mihint);
{│} end;

procedure TFormMenuHint.PopupListWndProc(var AMsg: TMessage);
{│}
{│}   function FindItemForCommand(APopupMenu: TPopupMenu; const AMenuMsg:                 TWMMenuSelect): TMenuItem;
{│}   var
{│}     SubMenu: HMENU;
{│}   begin
{│}     Assert(APopupMenu <> nil);
{│}     // menuitem
{│}     Result := APopupMenu.FindItem(AMenuMsg.IDItem, fkCommand);
{│}     if Result = nil then begin
{│}       // submenu
{│}       SubMenu := GetSubMenu(AMenuMsg.Menu, AMenuMsg.IDItem);
{│}       if SubMenu <> 0 then
{│}         Result := APopupMenu.FindItem(SubMenu, fkHandle);
{│}     end;
{│}   end;
{│}
{│} var
{│}   Msg: TWMMenuSelect;
{│}   menuItem: TMenuItem;
{│}   MenuIndex: integer;
{│}
{│} begin
{│}   AMsg.Result := CallWindowProc(fOldWndProc, VCL.Menus.PopupList.Window, AMsg.Msg,                             AMsg.WParam, AMsg.LParam);
{│}   if AMsg.Msg = WM_MENUSELECT then begin
{│}     menuItem := nil;
{│}     Msg := TWMMenuSelect(AMsg);
{│}     if (Msg.MenuFlag <> $FFFF) or (Msg.IDItem <> 0) then begin
{│}       for MenuIndex := 0 to PopupList.Count - 1 do begin
{│}         menuItem := FindItemForCommand(PopupList.Items[MenuIndex], Msg);
{│}         if menuItem <> nil then
{│}           break;
{│}       end;
{│}     end;
{│}     miHint.DoActivateHint(menuItem);
{│}   end;
{│} end;

end.

Several weeks ago I had to migrate from Embarcadero Delphi 10.3 to Delphi 11.3 (my CE lysense has expired). Trying to slightly change my old project I rebuilt it and got an ugly error: access violation in the deeps of user32.dll. It costed me a pint of blood to find two casts:

integer(NewWndProc) in FormCreate and
integer(fOldWndProc) in FormDestroy

which worked as 64-bit in 10.3 and became 32-bit in 11.3. Use nativeint() instead

Answer 2

WM_MENUSELECT is indeed handled for menu items in popup menus also, but not by the windows proc of the form containing the (popup) menu, but by an invisible helper window created by Menus.PopupList. Luckily you can (at least under Delphi 5) get at this HWND via Menus.PopupList.Window.

Now you can use the old-fashioned way to subclass a window, as described for example in this CodeGear article, to handle WM_MENUSELECT also for popup menus. The HWND will be valid from after the first TPopupMenu is created to before the last TPopupMenu object is destroyed.

A quick test with the demo app in the linked article in the question should reveal whether this is going to work.

Edit: It does indeed work. I changed the linked example to show hints also for the popup menu. Here are the steps:

Add a handler for OnDestroy, a member variable for the old window proc and a method for the new window proc to the form:

TForm1 = class(TForm)
  ...
  procedure FormCreate(Sender: TObject);
  procedure FormDestroy(Sender: TObject);
  procedure ApplicationEvents1Hint(Sender: TObject);
private
  miHint : TMenuItemHint;
  fOldWndProc: TFarProc;
  procedure WMMenuSelect(var Msg: TWMMenuSelect); message WM_MENUSELECT;
  procedure PopupListWndProc(var AMsg: TMessage);
end;

Change the OnCreate handler of the form to subclass the hidden PopupList window, and implement the proper restoration of the window proc in the OnDestroy handler:

procedure TForm1.FormCreate(Sender: TObject);
var
  NewWndProc: TFarProc;
begin
  miHint := TMenuItemHint.Create(self);

  NewWndProc := MakeObjectInstance(PopupListWndProc);
  fOldWndProc := TFarProc(SetWindowLong(Menus.PopupList.Window, GWL_WNDPROC,
    integer(NewWndProc)));
end;

procedure TForm1.FormDestroy(Sender: TObject);
var
  NewWndProc: TFarProc;
begin
  NewWndProc := TFarProc(SetWindowLong(Menus.PopupList.Window, GWL_WNDPROC,
    integer(fOldWndProc)));
  FreeObjectInstance(NewWndProc);
end;

Implement the subclassed window proc:

procedure TForm1.PopupListWndProc(var AMsg: TMessage);

  function FindItemForCommand(APopupMenu: TPopupMenu;
    const AMenuMsg: TWMMenuSelect): TMenuItem;
  var
    SubMenu: HMENU;
  begin
    Assert(APopupMenu <> nil);
    // menuitem
    Result := APopupMenu.FindItem(AMenuMsg.IDItem, fkCommand);
    if Result = nil then begin
      // submenu
      SubMenu := GetSubMenu(AMenuMsg.Menu, AMenuMsg.IDItem);
      if SubMenu <> 0 then
        Result := APopupMenu.FindItem(SubMenu, fkHandle);
    end;
  end;

var
  Msg: TWMMenuSelect;
  menuItem: TMenuItem;
  MenuIndex: integer;
begin
  AMsg.Result := CallWindowProc(fOldWndProc, Menus.PopupList.Window,
    AMsg.Msg, AMsg.WParam, AMsg.LParam);
  if AMsg.Msg = WM_MENUSELECT then begin
    menuItem := nil;
    Msg := TWMMenuSelect(AMsg);
    if (Msg.MenuFlag <> $FFFF) or (Msg.IDItem <> 0) then begin
      for MenuIndex := 0 to PopupList.Count - 1 do begin
        menuItem := FindItemForCommand(PopupList.Items[MenuIndex], Msg);
        if menuItem <> nil then
          break;
      end;
    end;
    miHint.DoActivateHint(menuItem);
  end;
end;

This is done for all popup menus in a loop, until the first matching item or submenu is found.

Answer 3

Not sure if it helps, but I have created my own multi-line hint window (for Delphi7) to be able to show more then just one line of text. It's open source and you can find it here.

There is some work involved showing it on the right location on the screen, but you have full control over it.