Как отобразить подсказку меню

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; // от TCustomForm (гарантирует, что Application.Hint применен)

   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
   // силой удаляет "старое" окно подсказки
   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
     // позиция и размеры
     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
   // скрывает (разрушает) окно подсказки
   self.ReleaseHandle;
   hideTimer.OnTimer := nil;
end; {*HideTime*}

end.

Продолжение следует ...