How to Display Menu Item Hints in Delphi Applications (Revisited)

Last week I decided I wanted the main menu hints and popup menu hints to display in a tooltip window just like the hints for all the other controls. I figured it shouldn't be that difficult, right. Microsoft does it all over the place so why shouldn't my applications.

Wow did I under estimate what it takes to pull this one off.

It turns out that menuitem hints by design are intended to display in the status bar. Who's bright idea was that? I don't know about you but when I mouseover stuff my eyes look where the mouse cursor is. I hardly ever look down at the status bar.

So, I turned to google and began my search for code. I figured that someone has already done this and I can just implement their solution. Almost but not quite.

Here are my requirements:

Display all main menu hints in a tooltip
Display all popup menu hints in a tooltip
Display multi-line menu hints as multi-lines

I'd like to thank Zarko Gajic and mghie (from stackoverflow) for doing all the hard work and providing the code base that I tweaked in my final implementation.

How to Display Menu Item Hints in Delphi Applications - Zarko Gajic
Display a ToolTip hint on a disabled menu item of a popup menu - mghie

I have heavily commented the code below for a very specific reason. I wanted it to standout from all the other code in my application. Here is what the folded code looks like in my IDE

Yes those are real box drawing characters. I like the way the structured comments keeps all the code needed for the menuhints implementation in a nice, visual group.

Semper Fi,
Gunny Mike

Add to Uses
Vcl.Menus
Vcl.ExtCtrls

Interface Section

{┌────────────────────────────────────────────────────────────┐}
{│ MenuHints Type Declaration                                 │}
{├────────────────────────────────────────────────────────────┤}
{│ How to Display Menu Item Hints in Delphi Applications      │}
{│ http://delphi.about.com/od/vclusing/a/menuitemhints.htm    │}
{│ Zarko Gajic                                                │}
{├────────────────────────────────────────────────────────────┘}
{│} 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;
{│} {  End TMenuItemHint }
{└─────────────────────────────────────────────────────────────}

TForm Private Declarations

{ Private declarations }
{┌────────────────────────────────────────────────────────────┐}
{│ MenuHints Form Private Declartions                         │}
{├────────────────────────────────────────────────────────────┤}
{│ Adapted from Zarko Gajic's article called                  │}
{│ How to Display Menu Item Hints in Delphi Applications      │}
{│ http://delphi.about.com/od/vclusing/a/menuitemhints.htm    │}
{│                                                            │}
{│ Further adapted by mghie's stackoverflow answer to         │}
{│ Display a ToolTip hint on a disabled menu item of a        │}
{│ popup menu                                                 │}
{│ http://stackoverflow.com/questions/470696/#471065          │}
{│                                                            │}
{│ Important:                                                 │}
{│ Add call to MenuHintOnCreate in the form OnCreate method   │}
{│ Add call to MenuHintOnDestroy in the form OnDestroy method │}
{├────────────────────────────────────────────────────────────┘}
{│} miHint : TMenuItemHint;
{│} fOldWndProc: TFarProc;
{└─────────────────────────────────────────────────────────────}
{┌────────────────────────────────────────────────────────────┐}
{│ MenuHints Form Private Declartions Contiinued              │}
{├────────────────────────────────────────────────────────────┘}
{│} Procedure MenuHintOnCreate;
{│} Procedure MenuHintOnDestroy;
{│} procedure WMMenuSelect(var Msg: TWMMenuSelect); message WM_MENUSELECT;
{│} procedure PopupListWndProc(var AMsg: TMessage);  public
{└─────────────────────────────────────────────────────────────}

Form OnCreate / OnDestroy

procedure TfrmMain.FormCreate(Sender: TObject);
begin
  {┌────────────────────────────────────────────────────────────┐}
  {│ MenuHints:                                                 │}
  {├────────────────────────────────────────────────────────────┘}
  {│} MenuHintOnCreate;
  {└─────────────────────────────────────────────────────────────}
end;
 
procedure TfrmMain.FormDestroy(Sender: TObject);
begin
  {┌────────────────────────────────────────────────────────────┐}
  {│ MenuHints:                                                 │}
  {├────────────────────────────────────────────────────────────┘}
  {│} MenuHintOnDestroy;
  {└─────────────────────────────────────────────────────────────}
end;

Implementation Section

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

173

174

175

176

177

178

179

180

181

182

183

184

185

186

187

188

189

190

191

192

193

194

195

196

197

198

199

{┌────────────────────────────────────────────────────────────┐}
{│ MenuHints Implementation                                   │}
{├────────────────────────────────────────────────────────────┤}
{│ Adapted from Zarko Gajic's article called                  │}
{│ How to Display Menu Item Hints in Delphi Applications      │}
{│ http://delphi.about.com/od/vclusing/a/menuitemhints.htm    │}
{│                                                            │}
{│ Further adapted by mghie's stackoverflow answer to         │}
{│ Display a ToolTip hint on a disabled menu item of a        │}
{│ popup menu                                                 │}
{│ http://stackoverflow.com/questions/470696/#471065          │}
{│                                                            │}
{│ Modified to accomodate multi line hints                    │}
{├────────────────────────────────────────────────────────────┤}
{│ Generic Section                                            │}
{├────────────────────────────────────────────────────────────┘}
{│} procedure TMenuItemHint.HideTime(Sender: TObject);
{│} begin
{│}    //hide (destroy) hint window
{│}    self.ReleaseHandle;
{│}    hideTimer.OnTimer := nil;
{│} end;
{├────────────────────────────────────────────────────────────┐}
{│ procedure: TMenuItemHint.ShowTime                          │}
{│ Modified:  12/27/2014                                      │}
{│ By:        Michael Riley                                   │}
{│ Reason:    Accomodate multi line hints                     │}
{│            Changed the position and size of the TRect      │}
{├────────────────────────────────────────────────────────────┘}
{│} 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;
{│} 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.OnTimer := nil;
{│}   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;
{├────────────────────────────────────────────────────────────┐}
{│ Form Specific Section                                      │}
{├────────────────────────────────────────────────────────────┘}
{│} procedure TfrmMain.MenuHintOnCreate;
{│} var
{│}   NewWndProc: TFarProc;
{│} begin
{│}   miHint := TMenuItemHint.Create(self);
{│}   NewWndProc := MakeObjectInstance(PopupListWndProc);
{│}   fOldWndProc := TFarProc(SetWindowLong(VCL.Menus.PopupList.Window, GWL_WNDPROC, integer(NewWndProc)));
{│} end;
{├─────────────────────────────────────────────────────────────}
{│} procedure TfrmMain.MenuHintOnDestroy;
{│} var
{│}   NewWndProc: TFarProc;
{│} begin
{│}   NewWndProc := TFarProc(SetWindowLong(VCL.Menus.PopupList.Window, GWL_WNDPROC, integer(fOldWndProc)));
{│}   FreeObjectInstance(NewWndProc);
{│} end;
{├─────────────────────────────────────────────────────────────}
{│} procedure TfrmMain.WMMenuSelect(var Msg: TWMMenuSelect);
{│} var
{│}   menuItem : TMenuItem;
{│}   hSubMenu : HMENU;
{│} begin
{│}   inherited; // from TCustomForm
{│}
{│}   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*)
{├─────────────────────────────────────────────────────────────}
{│} procedure TfrmMain.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.

Cape Cod Gunny - Michael Riley

Sunday, December 28, 2014

How to Display Menu Item Hints in Delphi Applications (Revisited)

No comments:

Post a Comment