实现多行toolTips的类模块
注：本文转自CSDN论坛
这里有一个类模块,就是用来实现多行 toolTips 的.
Option Explicit
'============================================================='
' Module Name : mdlAPI
' Written By : Gordon Robinson
' Date : 08/05/2000
' Comments :
'
'============================================================='
'============================================================='
' Constants
'============================================================='
Private Const TTS_ALWAYSTIP = &H1
Private Const TTS_NOPREFIX = &H2
Private Const CW_USEDEFAULT = &H80000000
Private Const WS_POPUP = &H80000000
Private Const WM_USER = &H400
Private Const TTM_ADDTOOL = WM_USER + 4
Private Const TTM_SETMAXTIPWIDTH = WM_USER + 24
Private Const TTM_SETDELAYTIME = WM_USER + 3
Private Const TTM_GETDELAYTIME = WM_USER + 21
Private Const TTDT_AUTOMATIC = 0
Private Const TTDT_RESHOW = 1
Private Const TTDT_AUTOPOP = 2
Private Const TTDT_INITIAL = 3
Private Const TTF_SUBCLASS = &H10
Private Const TTF_IDISHWND = &H1
Private Const TTF_CENTERTIP = &H2
'============================================================='
' Types
'============================================================='
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type TOOLINFO
cbSize As Long
uFlags As Long
hwnd As Long
uId As Long
cRect As RECT
hinst As Long
lpszText As String
End Type
'============================================================='
' API Functions
'============================================================='
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 DestroyWindow Lib "user32" _
(ByVal hwnd As Long) _
As Long
Private Declare Function GetClientRect Lib "user32" _
(ByVal hwnd As Long, _
lpRect As RECT) _
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 SendMessageLong Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) _
As Long
'====================================================================='
' Member Variables
'====================================================================='
Private m_lngHwnd As Long
Private m_lngMaxWidth As Long
'====================================================================='
' Properties
'====================================================================='
Public Property Get MaxWidth() As Long
MaxWidth = m_lngMaxWidth
End Property
Public Property Let MaxWidth(lngMaxWidth As Long)
m_lngMaxWidth = lngMaxWidth
SendMessageLong m_lngHwnd, TTM_SETMAXTIPWIDTH, 0, m_lngMaxWidth
End Property
Public Property Get VisibleTime() As Long
VisibleTime = SendMessageLong(m_lngHwnd, TTM_GETDELAYTIME, TTDT_AUTOPOP, 0)
End Property
Public Property Let VisibleTime(lngTime As Long)
If lngTime > 32767 Then lngTime = 32767
If lngTime < 0 Then lngTime = 0
SendMessageLong m_lngHwnd, TTM_SETDELAYTIME, TTDT_AUTOPOP, lngTime
End Property
Public Property Get DelayTime() As Long
DelayTime = SendMessageLong(m_lngHwnd, TTM_GETDELAYTIME, TTDT_INITIAL, 0)
End Property
Public Property Let DelayTime(lngTime As Long)
If lngTime > 32767 Then lngTime = 32767
If lngTime < 0 Then lngTime = 0
SendMessageLong m_lngHwnd, TTM_SETDELAYTIME, TTDT_INITIAL, lngTime
End Property
'====================================================================='
' Methods
'====================================================================='
Public Sub Create(lngHwndParent As Long)
m_lngHwnd = CreateWindowEx(0, _
"tooltips_class32", _
0, _
TTS_NOPREFIX Or TTS_ALWAYSTIP, _
CW_USEDEFAULT, _
CW_USEDEFAULT, _
CW_USEDEFAULT, _
CW_USEDEFAULT, _
lngHwndParent, _
0, _
App.hInstance, _
0)
SendMessageLong m_lngHwnd, TTM_SETMAXTIPWIDTH, 0, m_lngMaxWidth
End Sub
Public Sub Destroy()
DestroyWindow m_lngHwnd
End Sub
Public Sub AddControl(ctlTool As Object, strCaption As String, Optional blnCenterTip As Boolean = False)
Dim udtToolInfo As TOOLINFO
With udtToolInfo
GetClientRect ctlTool.hwnd, .cRect
.hwnd = ctlTool.hwnd
.uFlags = TTF_IDISHWND Or TTF_SUBCLASS
If blnCenterTip Then
.uFlags = .uFlags Or TTF_CENTERTIP
End If
.uId = ctlTool.hwnd
.lpszText = strCaption
.cbSize = Len(udtToolInfo)
End With
SendMessage m_lngHwnd, TTM_ADDTOOL, 0, udtToolInfo
End Sub
'====================================================================='
' Events
'====================================================================='
Private Sub Class_Initialize()
m_lngMaxWidth = 300
End Sub
【使用方法】
将上面那段源程序存为一个类模块,名为 cTooltop
首先应该建立一个form然后在form上添加文本框：复选框chkAddToCurrentGroup，txtemail,txttelephone,...然后就可以了
然后在窗体的 Form_Load 中写如下代码即可.
Dim ct As New cTooltip
'========================================================
'设置多行的提示信息
ct.Create Me.hwnd '父窗体句柄
ct.DelayTime = 100 '延迟时间
ct.VisibleTime = 5000 '显示时间
ct.AddControl chkAddToCurrentGroup, "如果选中此项,那么数据录入时," & vbCrLf & _
"同时将此记录加入当前选中了的分组。" & vbCrLf & _
"如果选中了多个组，那么它将加入多个组"
ct.AddControl txtAddress, "这里的地址是指除去省名、地区之外的更详细的地址。" & vbCrLf & _
"也就是说,这里不必也不能填写省名、地区了。" & vbCrLf & _
"例如: 广东省广州市中山八路 8888 号" & vbCrLf & _
"在此只需填写 “中山八路 8888 号”即可"
ct.AddControl txtUnit, "这里填写单位、公司。" & vbCrLf & _
"如:大发公司财务处"
ct.AddControl txtTelephone, "你可以在此快速录入电话号码." & vbCrLf & _
"号码之间以分号(;)分隔." & vbCrLf & _
"电话号码以类别字母开头(缺省认为家庭电话)" & vbCrLf & _
"类别字母为(注意数字 0 与字母 o 的区别):" & vbCrLf & _
"o 办公 h 家庭 m 移动 f 传真 c 呼机" & vbCrLf & _
"例如:o020-87332053-8888;m13660888888;c95950-88888"
ct.AddControl txtEmail, "你可以在此快速录入电子邮箱." & vbCrLf & _
"邮箱之间以分号(;)分隔." & vbCrLf & _
"如:[email protected];[email protected]"
这里有一个类模块,就是用来实现多行 toolTips 的.
Option Explicit
'============================================================='
' Module Name : mdlAPI
' Written By : Gordon Robinson
' Date : 08/05/2000
' Comments :
'
'============================================================='
'============================================================='
' Constants
'============================================================='
Private Const TTS_ALWAYSTIP = &H1
Private Const TTS_NOPREFIX = &H2
Private Const CW_USEDEFAULT = &H80000000
Private Const WS_POPUP = &H80000000
Private Const WM_USER = &H400
Private Const TTM_ADDTOOL = WM_USER + 4
Private Const TTM_SETMAXTIPWIDTH = WM_USER + 24
Private Const TTM_SETDELAYTIME = WM_USER + 3
Private Const TTM_GETDELAYTIME = WM_USER + 21
Private Const TTDT_AUTOMATIC = 0
Private Const TTDT_RESHOW = 1
Private Const TTDT_AUTOPOP = 2
Private Const TTDT_INITIAL = 3
Private Const TTF_SUBCLASS = &H10
Private Const TTF_IDISHWND = &H1
Private Const TTF_CENTERTIP = &H2
'============================================================='
' Types
'============================================================='
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type TOOLINFO
cbSize As Long
uFlags As Long
hwnd As Long
uId As Long
cRect As RECT
hinst As Long
lpszText As String
End Type
'============================================================='
' API Functions
'============================================================='
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 DestroyWindow Lib "user32" _
(ByVal hwnd As Long) _
As Long
Private Declare Function GetClientRect Lib "user32" _
(ByVal hwnd As Long, _
lpRect As RECT) _
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 SendMessageLong Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) _
As Long
'====================================================================='
' Member Variables
'====================================================================='
Private m_lngHwnd As Long
Private m_lngMaxWidth As Long
'====================================================================='
' Properties
'====================================================================='
Public Property Get MaxWidth() As Long
MaxWidth = m_lngMaxWidth
End Property
Public Property Let MaxWidth(lngMaxWidth As Long)
m_lngMaxWidth = lngMaxWidth
SendMessageLong m_lngHwnd, TTM_SETMAXTIPWIDTH, 0, m_lngMaxWidth
End Property
Public Property Get VisibleTime() As Long
VisibleTime = SendMessageLong(m_lngHwnd, TTM_GETDELAYTIME, TTDT_AUTOPOP, 0)
End Property
Public Property Let VisibleTime(lngTime As Long)
If lngTime > 32767 Then lngTime = 32767
If lngTime < 0 Then lngTime = 0
SendMessageLong m_lngHwnd, TTM_SETDELAYTIME, TTDT_AUTOPOP, lngTime
End Property
Public Property Get DelayTime() As Long
DelayTime = SendMessageLong(m_lngHwnd, TTM_GETDELAYTIME, TTDT_INITIAL, 0)
End Property
Public Property Let DelayTime(lngTime As Long)
If lngTime > 32767 Then lngTime = 32767
If lngTime < 0 Then lngTime = 0
SendMessageLong m_lngHwnd, TTM_SETDELAYTIME, TTDT_INITIAL, lngTime
End Property
'====================================================================='
' Methods
'====================================================================='
Public Sub Create(lngHwndParent As Long)
m_lngHwnd = CreateWindowEx(0, _
"tooltips_class32", _
0, _
TTS_NOPREFIX Or TTS_ALWAYSTIP, _
CW_USEDEFAULT, _
CW_USEDEFAULT, _
CW_USEDEFAULT, _
CW_USEDEFAULT, _
lngHwndParent, _
0, _
App.hInstance, _
0)
SendMessageLong m_lngHwnd, TTM_SETMAXTIPWIDTH, 0, m_lngMaxWidth
End Sub
Public Sub Destroy()
DestroyWindow m_lngHwnd
End Sub
Public Sub AddControl(ctlTool As Object, strCaption As String, Optional blnCenterTip As Boolean = False)
Dim udtToolInfo As TOOLINFO
With udtToolInfo
GetClientRect ctlTool.hwnd, .cRect
.hwnd = ctlTool.hwnd
.uFlags = TTF_IDISHWND Or TTF_SUBCLASS
If blnCenterTip Then
.uFlags = .uFlags Or TTF_CENTERTIP
End If
.uId = ctlTool.hwnd
.lpszText = strCaption
.cbSize = Len(udtToolInfo)
End With
SendMessage m_lngHwnd, TTM_ADDTOOL, 0, udtToolInfo
End Sub
'====================================================================='
' Events
'====================================================================='
Private Sub Class_Initialize()
m_lngMaxWidth = 300
End Sub
【使用方法】
将上面那段源程序存为一个类模块,名为 cTooltop
首先应该建立一个form然后在form上添加文本框：复选框chkAddToCurrentGroup，txtemail,txttelephone,...然后就可以了
然后在窗体的 Form_Load 中写如下代码即可.
Dim ct As New cTooltip
'========================================================
'设置多行的提示信息
ct.Create Me.hwnd '父窗体句柄
ct.DelayTime = 100 '延迟时间
ct.VisibleTime = 5000 '显示时间
ct.AddControl chkAddToCurrentGroup, "如果选中此项,那么数据录入时," & vbCrLf & _
"同时将此记录加入当前选中了的分组。" & vbCrLf & _
"如果选中了多个组，那么它将加入多个组"
ct.AddControl txtAddress, "这里的地址是指除去省名、地区之外的更详细的地址。" & vbCrLf & _
"也就是说,这里不必也不能填写省名、地区了。" & vbCrLf & _
"例如: 广东省广州市中山八路 8888 号" & vbCrLf & _
"在此只需填写 “中山八路 8888 号”即可"
ct.AddControl txtUnit, "这里填写单位、公司。" & vbCrLf & _
"如:大发公司财务处"
ct.AddControl txtTelephone, "你可以在此快速录入电话号码." & vbCrLf & _
"号码之间以分号(;)分隔." & vbCrLf & _
"电话号码以类别字母开头(缺省认为家庭电话)" & vbCrLf & _
"类别字母为(注意数字 0 与字母 o 的区别):" & vbCrLf & _
"o 办公 h 家庭 m 移动 f 传真 c 呼机" & vbCrLf & _
"例如:o020-87332053-8888;m13660888888;c95950-88888"
ct.AddControl txtEmail, "你可以在此快速录入电子邮箱." & vbCrLf & _
"邮箱之间以分号(;)分隔." & vbCrLf & _
"如:[email protected];[email protected]"