Menu Item Hints in Delphi applications
Create a new Delphi application. On the main form drop a ("Menu1")TMenu (Standard palette), a TStatusBar (Win32 palette) and a TApplicationEvents (Additional palette) component. Add several menu items to menu. Let some menu items have assigned a Hint property, let some menu items be Hint "free".Here's the full source code (download) of the Form's Unit, along with the implementation of the TMenuItemHint class:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics,
Controls, Forms,Dialogs, Menus, AppEvnts,
StdCtrls, ExtCtrls, ComCtrls;
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;
procedure DoActivateHint(menuItem : TMenuItem) ;
destructor Destroy; override;
end;
TForm1 = class(TForm)
...
procedure FormCreate(Sender: TObject) ;
procedure ApplicationEvents1Hint(Sender: TObject) ;
private
miHint : TMenuItemHint;
procedure WMMenuSelect(var Msg: TWMMenuSelect) ; message WM_MENUSELECT;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject) ;
begin
miHint := TMenuItemHint.Create(self) ;
end; (*FormCreate*)
procedure TForm1.ApplicationEvents1Hint(Sender: TObject) ;
begin
StatusBar1.SimpleText := 'App.OnHint : ' + Application.Hint;
end; (*Application.OnHint*)
procedure TForm1.WMMenuSelect(var Msg: TWMMenuSelect) ;
var
menuItem : TMenuItem;
hSubMenu : HMENU;
begin
inherited; // from TCustomForm (ensures that Application.Hint is assigned)
menuItem := nil;
if (Msg.MenuFlag <> $FFFF) or (Msg.IDItem <> 0) then
begin
if Msg.MenuFlag and MF_POPUP = MF_POPUP then
begin
hSubMenu := GetSubMenu(Msg.Menu, Msg.IDItem) ;
menuItem := Self.Menu.FindItem(hSubMenu, fkHandle) ;
end
else
begin
menuItem := Self.Menu.FindItem(Msg.IDItem, fkCommand) ;
end;
end;
miHint.DoActivateHint(menuItem) ;
end; (*WMMenuSelect*)
{ TMenuItemHint }
constructor TMenuItemHint.Create(AOwner: TComponent) ;
begin
inherited;
showTimer := TTimer.Create(self) ;
showTimer.Interval := Application.HintPause;
hideTimer := TTimer.Create(self) ;
hideTimer.Interval := Application.HintHidePause;
end; (*Create*)
destructor TMenuItemHint.Destroy;
begin
hideTimer.OnTimer := nil;
showTimer.OnTimer := nil;
self.ReleaseHandle;
inherited;
end; (*Destroy*)
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; (*DoActivateHint*)
procedure TMenuItemHint.ShowTime(Sender: TObject) ;
var
r : TRect;
wdth : integer;
hght : integer;
begin
if activeMenuItem <> nil then
begin
//position and resize
wdth := Canvas.TextWidth(activeMenuItem.Hint) ;
hght := Canvas.TextHeight(activeMenuItem.Hint) ;
r.Left := Mouse.CursorPos.X + 16;
r.Top := Mouse.CursorPos.Y + 16;
r.Right := r.Left + wdth + 6;
r.Bottom := r.Top + hght + 4;
ActivateHint(r,activeMenuItem.Hint) ;
end;
showTimer.OnTimer := nil;
end; (*ShowTime*)
procedure TMenuItemHint.HideTime(Sender: TObject) ;
begin
//hide (destroy) hint window
self.ReleaseHandle;
hideTimer.OnTimer := nil;
end; (*HideTime*)
end.