注：本文转自论坛
这里有一个类模块,就是用来实现多行 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 & _ "如:yourgod@god.com;mygod@god.net"
转载于:https://www.cnblogs.com/feima-lxl/archive/2008/06/23/1228218.html
