在VB中使用气泡形多行提示
软件世界
VB中的提示都是单行长方形的，不但很难看，而且不能显示多行提示，很不方便。笔者经过摸索，找出了制作气泡形多行提示的方法。以制作一个如图所示的汽泡形两行提示为例，代码如下：（图1）
Class:
Option Explicit
Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long '创建窗口
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long '发出消息
Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Const WM_USER = &H400
Private Const CW_USEDEFAULT = &H80000000
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Const TTS_NOPREFIX = &H2
Private Const TTF_TRANSPARENT = &H100
Private Const TTF_CENTERTIP = &H2
Private Const TTM_ADDTOOLA = (WM_USER + 4)
Private Const TTM_ACTIVATE = WM_USER + 1
Private Const TTM_UPDATETIPTEXTA = (WM_USER + 12)
Private Const TTM_SETMAXTIPWIDTH = (WM_USER + 24)
Private Const TTM_SETTITLE = (WM_USER + 32)
Private Const TTS_BALLOON = &H40
Private Const TTF_SUBCLASS = &H10
Private Const TOOLTIPS_CLASSA = "tooltips_class32"
Private Type TOOLINFO
lSize As Long
lFlags As Long
lHwnd As Long
lId As Long
lpRect As RECT
hInstance As Long
lpStr As String
lParam As Long
End Type
Private TTTitle As String
Private TTParentControl As Object
Private TTStyle As TTStyleEnum
Public Enum TTStyleEnum
TTStandard
TTBalloon
End Enum
Private hToolTipHwnd As Long
Private TI As TOOLINFO
'创建函数
Public Function Create() As Boolean
Dim lpRect As RECT
DestroyWindow hToolTipHwnd
'建立tooltip窗口
hToolTipHwnd = CreateWindowEx(0, TOOLTIPS_CLASSA, vbNullString, TTS_BALLOON, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, TTParentControl.hwnd, 0, App.hInstance, 0)
GetClientRect TTParentControl.hwnd, lpRect
'设置tooltip
With TI
.lFlags = TTF_SUBCLASS
.lHwnd = TTParentControl.hwnd
.lId = 0
.hInstance = App.hInstance
.lpRect = lpRect
End With
SendMessage hToolTipHwnd, TTM_ADDTOOLA, 0, TI
'给tooltip加上标题
SendMessage hToolTipHwnd, TTM_SETTITLE, 0, ByVal TTTitle
End Function
'确定tooltip对象(要求有hwnd的控件)
Public Property Set ParentControl(ByVal vData As Object)
Set TTParentControl = vData
End Property
'设置tooltip的标题
Public Property Let ToolTipTitle(ByVal vData As String)
TTTitle = vData
SendMessage hToolTipHwnd, TTM_SETTITLE, 0, ByVal TTTitle
End Property
'设置tooltip的文本(支持多行)
Public Property Let ToolTipText(ByVal vData As String)
TI.lpStr = vData
SendMessage hToolTipHwnd, TTM_UPDATETIPTEXTA, 0, TI
End Property
End Class1
Form1
Option Explicit
'定义tooltip
Dim tooltip As New clsToolTip
Private Sub Form_Load()
'注意这里要用Set
Set tooltip.ParentControl = Text1
tooltip.ToolTipTitle = "Hello!"
tooltip.ToolTipText = "Ahhhhhhhhhhhhhh!"
tooltip.Create
End Sub
End Form1
通过以上实例，各位就不难“如法炮制”出满意的气泡形多行提示。