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

Code:

{

In-place ToolTips are used to display text strings for objects that have been clipped,

in TreeView for example. The following code has been tested only on standard ListBox.

Of cause you can use tips on other VCLs after appropriate modification.

(Only copy following code to your form1's unit file)

}

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

//  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 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.