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 )
Button1 : TButton ;
Button2 : TButton ;
ListBox1 : TListBox ;
procedure FormCreate ( Sender : TObject );
procedure Button2Click ( Sender : TObject );
private
{ Private declarations }
GHWND : HWND ;
TipVisable : Boolean ;
OldIndex , CurrentIndex : Integer ;
ti : TOOLINFO ;
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 .