Title: How to show in-place Tooltips in a TListBox
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, CommCtrl;
type
//Override TListBox's WinProc to get CM_MOUSELEAVE message
TNewListBox = class(TListBox)
protected
{ Protected declarations }
procedure WndProc(var Message: TMessage); override;
end;
type
TForm1 = class(TForm)
Button2: TButton;
procedure FormCreate(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
GHWND: HWND;
TipVisable: Boolean;
OldIndex, CurrentIndex: Integer;
ti: TOOLINFO;
ListBox1: TListBox;
procedure InitListBox; //Create ListBox1 dynamically
procedure CreateTipsWindow; //Create Tooltip Window
procedure HideTipsWindow; //Hide Tooltip Window
//WM_NOTIFY message's handler, fill Tooltip Window content
procedure WMNotify(var Msg: TMessage); message WM_NOTIFY;
procedure ListBox_MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure ListBox_MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
{ TNewListBox }
procedure TNewListBox.WndProc(var Message: TMessage);
begin
case Message.Msg of
CM_MOUSELEAVE: Form1.HideTipsWindow;
end;
inherited WndProc(Message);
end;
{ TForm1 }
procedure TForm1.InitListBox;
begin
ListBox1 := TNewListBox.Create(Self);
ListBox1.Parent := Self;
ListBox1.Left := 50;
ListBox1.Top := 50;
ListBox1.Width := 200;
ListBox1.Height := 200;
//append serveral items for testing
ListBox1.Items.Append('happyjoe');
ListBox1.Items.Append('Please send me email: happyjoe@21cn.com');
ListBox1.Items.Append('Delphi 5 Developer''s Guide');
ListBox1.Items.Append('Delphi 5.X ADO/MTS/COM+ Advanced Development');
ListBox1.OnMouseMove := ListBox_MouseMove;
ListBox1.OnMouseDown := ListBox_MouseDown;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Self.Font.Name := 'Tahoma';
InitListBox;
CreateTipsWindow;
end;
procedure TForm1.CreateTipsWindow;
var
iccex: tagINITCOMMONCONTROLSEX;
begin
// Load the ToolTip class from the DLL.
iccex.dwSize := SizeOf(tagINITCOMMONCONTROLSEX);
iccex.dwICC := ICC_BAR_CLASSES;
InitCommonControlsEx(iccex);
// Create the ToolTip control.
GHWND := CreateWindow(TOOLTIPS_CLASS, '',
WS_POPUP,
Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT),
Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT),
0, 0, hInstance,
nil);
// Prepare TOOLINFO structure for use as tracking ToolTip.
ti.cbSize := SizeOf(ti);
ti.uFlags := TTF_IDISHWND + TTF_TRACK + TTF_ABSOLUTE + TTF_TRANSPARENT;
ti.hwnd := Self.Handle;
ti.uId := ListBox1.Handle;
ti.hinst := hInstance;
ti.lpszText := LPSTR_TEXTCALLBACK;
ti.Rect.Left := 0;
ti.Rect.Top := 0;
ti.Rect.Bottom := 0;
ti.Rect.Right := 0;
SendMessage(GHWND, WM_SETFONT, ListBox1.Font.Handle, Integer(LongBool(False)));
SendMessage(GHWND,TTM_ADDTOOL,0,Integer(@ti));
end;
procedure TForm1.WMNotify(var Msg: TMessage);
var
phd: PHDNotify;
NMTTDISPINFO: PNMTTDispInfo;
begin
phd := PHDNotify(Msg.lParam);
if phd.Hdr.hwndFrom = GHWND then
begin
if phd.Hdr.Code = TTN_NEEDTEXT then
begin
NMTTDISPINFO := PNMTTDispInfo(phd);
NMTTDISPINFO.lpszText := PChar(ListBox1.Items[CurrentIndex]);
end;
end;
end;
procedure TForm1.ListBox_MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if TipVisable then //when mouse down, hide Tooltip Window
begin
SendMessage(GHWND,TTM_TRACKACTIVATE,Integer(LongBool(False)), 0);
TipVisable := False;
end;
end;
procedure TForm1.ListBox_MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
var
Index: Integer;
APoint: TPoint;
ARect: TRect;
ScreenRect: TRect;
begin
Index := ListBox1.ItemAtPos(Point(X, Y), true);
if Index = -1 then
begin
SendMessage(GHWND,TTM_TRACKACTIVATE,Integer(LongBool(False)), 0);
OldIndex := -1;
TipVisable := False;
Exit;
end;
CurrentIndex := Index;
if Index = OldIndex then Exit;
if TipVisable then
begin
SendMessage(GHWND,TTM_TRACKACTIVATE,Integer(LongBool(False)), 0);
OldIndex := -1;
TipVisable := False;
end else
begin
ARect := ListBox1.ItemRect(Index);
if (ARect.Right - ARect.Left - 2) = ListBox1.Canvas.TextWidth(ListBox1.Items[Index]) then
begin
OldIndex := -1;
Exit;
end;
APoint := ListBox1.ClientToScreen(ARect.TopLeft);
windows.GetClientRect(GetDesktopWindow, ScreenRect);
if ListBox1.Canvas.TextWidth(ListBox1.Items[Index]) + APoint.X ScreenRect.Right then
APoint.X := ScreenRect.Right - ListBox1.Canvas.TextWidth(ListBox1.Items[Index]) - 5;
SendMessage(GHWND,
TTM_TRACKPOSITION,
0,
MAKELPARAM(APoint.x - 1, APoint.y - 2));
SendMessage(GHWND,TTM_TRACKACTIVATE,Integer(LongBool(True)), Integer(@ti));
OldIndex := Index;
TipVisable := True;
end;
end;
procedure TForm1.HideTipsWindow;
begin
if TipVisable then
begin
SendMessage(GHWND,TTM_TRACKACTIVATE,Integer(LongBool(False)), 0);
OldIndex := -1;
TipVisable := False;
end;
end;
// Test it:
procedure TForm1.Button2Click(Sender: TObject);
begin
InitListBox;
CreateTipsWindow;
end;
end.
end.