N年前整理的一个类。 Option Explicit'/*****************************************************************************/ '/* 这个类模块可以将ToolTipText属性显示成多行文本。 */ '/* 使用需按如下过程进行: */ '/* */ '/* 1. 声明一个新类 */ '/* Private m_objTooltip As MoreLineToolTip */ '/* 2. 赋值 */ '/* Set m_objTooltip = New MoreLineToolTip */ '/* With m_objTooltip */ '/* .Create Me.hwnd */ '/* .MaxWidth = 400 '提示条最大宽度(像素) */ '/* .VisibleTime = 2000 '显示时间(毫秒) */ '/* .DelayTime = 500 '延迟时间(毫秒) */ '/* .AddControl Text1, "This is a multiline" _ */ '/* + vbCrLf + "tooltip" */ '/* .AddControl Text2, "Another multiline" + vbCrLf + _ */ '/* "tooltip. This is really" + vbCrLf + _ */ '/* "easy to do. This one is centered" + vbCrLf + _ */ '/* "though.", True */ '/* End With */ '/* */ '/* 3. 程序结束时释放对象变量 */ '/* m_objTooltip.Destroy */ '/*****************************************************************************/'=============================================================' ' Module Name : mdlAPI ' Written By : Gordon Robinson ' Date : 08/05/2000 ' Comments : ' '=============================================================''=============================================================' ' Constants '============================================================='Public Const TTS_ALWAYSTIP = &H1 Public Const TTS_NOPREFIX = &H2Public Const CW_USEDEFAULT = &H80000000Public Const WS_POPUP = &H80000000Public Const WM_USER = &H400Public Const TTM_ADDTOOL = WM_USER + 4 Public Const TTM_SETMAXTIPWIDTH = WM_USER + 24 Public Const TTM_SETDELAYTIME = WM_USER + 3 Public Const TTM_GETDELAYTIME = WM_USER + 21Public Const TTDT_AUTOMATIC = 0 Public Const TTDT_RESHOW = 1 Public Const TTDT_AUTOPOP = 2 Public Const TTDT_INITIAL = 3Public Const TTF_SUBCLASS = &H10 Public Const TTF_IDISHWND = &H1 Public Const TTF_CENTERTIP = &H2 '=============================================================' ' Types '============================================================='Public Type RECT Left As Long Top As Long Right As Long Bottom As Long End TypePublic 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 '============================================================='Public 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 LongPublic Declare Function DestroyWindow Lib "user32" _ (ByVal hwnd As Long) _ As LongPublic Declare Function GetClientRect Lib "user32" _ (ByVal hwnd As Long, _ lpRect As RECT) _ As LongPublic Declare Function SendMessage Lib "user32" Alias "SendMessageA" _ (ByVal hwnd As Long, _ ByVal wMsg As Long, _ ByVal wParam As Long, _ lParam As Any) _ As LongPublic 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 Width = m_lngMaxWidthEnd PropertyPublic Property Let MaxWidth(lngMaxWidth As Long) m_lngMaxWidth = lngMaxWidth SendMessageLong m_lngHwnd, TTM_SETMAXTIPWIDTH, 0, m_lngMaxWidthEnd PropertyPublic Property Get VisibleTime() As Long VisibleTime = SendMessageLong(m_lngHwnd, TTM_GETDELAYTIME, TTDT_AUTOPOP, 0)End PropertyPublic 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, lngTimeEnd PropertyPublic Property Get DelayTime() As Long DelayTime = SendMessageLong(m_lngHwnd, TTM_GETDELAYTIME, TTDT_INITIAL, 0)End PropertyPublic Property Let DelayTime(lngTime As Long) If lngTime > 32767 Then lngTime = 32767 If lngTime < 0 Then lngTime = 0
End Sub '=====================================================================' ' Events '====================================================================='Private Sub Class_Initialize() m_lngMaxWidth = 300End Sub
给你一个很简单的例子你看下:新建一个lable,name是:lblTool,再新建一个command1,代码如下:看效果Private Sub Form_Load() lblTool.Visible = False End SubPrivate Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) lblTool.Visible = False End Sub Private Sub Command1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) lblTool.Caption = "大家好,我想换行" & vbCrLf & vbCrLf _ & "可以多行的拉!" lblTool.Left = X + 2000 lblTool.Top = Y + 1500 lblTool.Visible = True End Sub
如何建立多行的球状工具栏
*****************************************************************************
欢迎使用CSDN论坛阅读器 : CSDN Reader(附全部源代码)
http://www.cnblogs.com/feiyun0112/archive/2006/09/20/509783.html
Option Explicit'/*****************************************************************************/
'/* 这个类模块可以将ToolTipText属性显示成多行文本。 */
'/* 使用需按如下过程进行: */
'/* */
'/* 1. 声明一个新类 */
'/* Private m_objTooltip As MoreLineToolTip */
'/* 2. 赋值 */
'/* Set m_objTooltip = New MoreLineToolTip */
'/* With m_objTooltip */
'/* .Create Me.hwnd */
'/* .MaxWidth = 400 '提示条最大宽度(像素) */
'/* .VisibleTime = 2000 '显示时间(毫秒) */
'/* .DelayTime = 500 '延迟时间(毫秒) */
'/* .AddControl Text1, "This is a multiline" _ */
'/* + vbCrLf + "tooltip" */
'/* .AddControl Text2, "Another multiline" + vbCrLf + _ */
'/* "tooltip. This is really" + vbCrLf + _ */
'/* "easy to do. This one is centered" + vbCrLf + _ */
'/* "though.", True */
'/* End With */
'/* */
'/* 3. 程序结束时释放对象变量 */
'/* m_objTooltip.Destroy */
'/*****************************************************************************/'============================================================='
' Module Name : mdlAPI
' Written By : Gordon Robinson
' Date : 08/05/2000
' Comments :
'
'=============================================================''============================================================='
' Constants
'============================================================='Public Const TTS_ALWAYSTIP = &H1
Public Const TTS_NOPREFIX = &H2Public Const CW_USEDEFAULT = &H80000000Public Const WS_POPUP = &H80000000Public Const WM_USER = &H400Public Const TTM_ADDTOOL = WM_USER + 4
Public Const TTM_SETMAXTIPWIDTH = WM_USER + 24
Public Const TTM_SETDELAYTIME = WM_USER + 3
Public Const TTM_GETDELAYTIME = WM_USER + 21Public Const TTDT_AUTOMATIC = 0
Public Const TTDT_RESHOW = 1
Public Const TTDT_AUTOPOP = 2
Public Const TTDT_INITIAL = 3Public Const TTF_SUBCLASS = &H10
Public Const TTF_IDISHWND = &H1
Public Const TTF_CENTERTIP = &H2
'============================================================='
' Types
'============================================================='Public Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End TypePublic 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
'============================================================='Public 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 LongPublic Declare Function DestroyWindow Lib "user32" _
(ByVal hwnd As Long) _
As LongPublic Declare Function GetClientRect Lib "user32" _
(ByVal hwnd As Long, _
lpRect As RECT) _
As LongPublic Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
lParam As Any) _
As LongPublic 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 Width = m_lngMaxWidthEnd PropertyPublic Property Let MaxWidth(lngMaxWidth As Long) m_lngMaxWidth = lngMaxWidth
SendMessageLong m_lngHwnd, TTM_SETMAXTIPWIDTH, 0, m_lngMaxWidthEnd PropertyPublic Property Get VisibleTime() As Long VisibleTime = SendMessageLong(m_lngHwnd, TTM_GETDELAYTIME, TTDT_AUTOPOP, 0)End PropertyPublic 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, lngTimeEnd PropertyPublic Property Get DelayTime() As Long DelayTime = SendMessageLong(m_lngHwnd, TTM_GETDELAYTIME, TTDT_INITIAL, 0)End PropertyPublic 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, lngTimeEnd 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_lngMaxWidthEnd SubPublic Sub Destroy() DestroyWindow m_lngHwnd
End SubPublic 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 = 300End Sub
lblTool.Visible = False
End SubPrivate Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
lblTool.Visible = False
End Sub
Private Sub Command1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
lblTool.Caption = "大家好,我想换行" & vbCrLf & vbCrLf _
& "可以多行的拉!"
lblTool.Left = X + 2000
lblTool.Top = Y + 1500
lblTool.Visible = True
End Sub