大家知道 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.
[系统软件]如何在Linux系统上进行快速磁带备份 [C语言系列]如何在Jbuilder9中使用SQLServer JDBC驱动 [VB.NET程序]如何在Visual Basic 6.0 中连接加密的Access数据库 [VB.NET程序]如何在vb 中用api函数代替winsock控件建立网络连接… [Delphi程序]如何在delphi6中调试web程序 [Delphi程序]如何在Delphi中用代码来完成计算字段的创建 [Delphi程序]如何在Delphi应用程序中调用CHM文档 [Delphi程序]如何在Delphi中使用正则表达式 [Delphi程序]如何在delphi下和.net建立的webservice 进行协同工… [Delphi程序]如何在delphi 中画带箭头的直线(改自网上一位论坛…
|