如何在 Listbox 上显示 In-place Tooltips

大家知道 TreeView 上的节点如果显示不完全，鼠标移上去会出现一提示，这就是 In-place Tooltips。下面这段代码在 Listbox 上实现这一功能(下面代码只是在标准 Listbox 上测试，如果是自画的，则要修改)：

{直接将下面代码拷贝到新建工程中Form1的Unit1.pas文件即可运行，不需添加任何控件}

//------------------------------------------------------------------------------//  在 ListBox 上实现 In-place Tooltips//  原创作者：Joe Huang                 Email：Happyjoe@21cn.com////------------------------------------------------------------------------------

unit Unit1;

interface

uses  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,  Dialogs, StdCtrls, CommCtrl;

type  //改写 TListBox 拦截 CM_MOUSELEAVE 消息  TNewListBox = class(TListBox)  protected    { Protected declarations }    procedure WndProc(var Message: TMessage); override;  end;

type  TForm1 = class(TForm)    procedure FormCreate(Sender: TObject);  private    { Private declarations }    GHWND: HWND;    TipVisable: Boolean;    OldIndex, CurrentIndex: Integer;    ti: TOOLINFO;    ListBox1: TListBox;

    procedure InitListBox;   //动态生成 ListBox1    procedure CreateTipsWindow;  //生成 Tooltip Window    procedure HideTipsWindow;    //隐藏 Tooltip Window

    //拦截 WM_NOTIFY 消息，动态改变 Tooltip Window 显示的内容    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;  //添加几项，以供测试用  ListBox1.Items.Append('happyjoe');  ListBox1.Items.Append('Please send me email: happyjoe@21cn.com');  ListBox1.Items.Append('Delphi 5 开发人员指南');  ListBox1.Items.Append('Delphi 5.X ADO/MTS/COM+ 高级程序设计篇');

  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     //当鼠标按下，将显示的 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  //如果鼠标下没有 Item，将 Tooltip Window 隐藏  begin    SendMessage(GHWND,TTM_TRACKACTIVATE,Integer(LongBool(false)), 0);    OldIndex := -1;    TipVisable := false;    exit;  end;  CurrentIndex := Index;    if Index = OldIndex then exit;  //如果鼠标在同一 Item 上移动，退出处理  if TipVisable then   //先将显示的 Tooltip Window 隐藏  begin    SendMessage(GHWND,TTM_TRACKACTIVATE,Integer(LongBool(false)), 0);    OldIndex := -1;    TipVisable := false;  end else  begin    ARect := ListBox1.ItemRect(Index);    //判断该 Item 是否完全显示    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);    //判断 Tooltip Window 显示后是否会超出屏幕范围，这里只判断了右边界    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;

end.