Показ in-place подсказки в TListBox и других компонентах

Code:

//------------------------------------------------------------------------------

//  Show in-place tooltips on ListBox

//  Author??Joe Huang                 Email??Этот адрес электронной почты защищён от спам-ботов. У вас должен быть включен JavaScript для просмотра.

//

//------------------------------------------------------------------------------

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: Этот адрес электронной почты защищён от спам-ботов. У вас должен быть включен JavaScript для просмотра.');

ListBox1.Items.Append('Delphi 5 Developers 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.