如何将鼠标移到时的文字提示行分成二行以上
鼠标移到某控件上,会显示一行说明文字框,但有时框中说明文字太长,如何将其分成二行以上?
[解决办法]
用以下代码就可以解决问题：
先建一个模块，全部内容为：
Public Const TTS_ALWAYSTIP = &H1
Public Const TTS_NOPREFIX = &H2
Public Const TTS_BALLOON = &H40
Public Const CW_USEDEFAULT = &H80000000
Public Const WS_POPUP = &H80000000
Public Const WM_USER = &H400
' ÌáʾµÄÏûÏ¢
Public Const TTM_SETDELAYTIME = (WM_USER + 3)
Public Const TTM_ADDTOOL = (WM_USER + 4)
Public Const TTM_SETTIPBKCOLOR = (WM_USER + 19)
Public Const TTM_SETTIPTEXTCOLOR = (WM_USER + 20)
Public Const TTM_GETTIPBKCOLOR = (WM_USER + 22)
Public Const TTM_GETTIPTEXTCOLOR = (WM_USER + 23)
Public Const TTM_SETMAXTIPWIDTH = (WM_USER + 24)
Public Const TTDT_AUTOMATIC = 0
Public Const TTDT_RESHOW = 1
Public Const TTDT_AUTOPOP = 2
Public Const TTDT_INITIAL = 3
Public Const TTF_IDISHWND = &H1
Public Const TTF_CENTERTIP = &H2
Public Const TTF_SUBCLASS = &H10
Public Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Public 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
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 Long
Public Declare Function DestroyWindow Lib "user32 " (ByVal hwnd As Long) As Long
Public 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
Public Declare Function GetClientRect Lib "user32 " (ByVal hwnd As Long, lpRect As RECT) As Long
Public Declare Function SendMessage Lib "user32 " Alias "SendMessageA " (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Declare Sub InitCommonControls Lib "comctl32.dll " ()
Public bCreated As Boolean, hTT As Long
Public hCreated() As Long
Public Sub CreateTTWindow(hParent As Long, Optional bBalloon As Boolean = False)
Dim h As Long, lStyle As Long
lStyle = TTS_NOPREFIX Or TTS_ALWAYSTIP
InitCommonControls
If bBalloon Then lStyle = lStyle Or TTS_BALLOON
hTT = CreateWindowEx(0, "tooltips_class32 ", 0, lStyle, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, hParent, 0, App.hInstance, 0)
If hTT = 0 Then MsgBox "´íÎó£¡ÎÞ·¨½¨Á¢¹¤¾ßÌáʾ´°¿Ú£¡ ", vbCritical, "´íÎó "
If Not bCreated Then
ReDim hCreated(0)
bCreated = True
Else
ReDim Preserve hCreated(UBound(hCreated) + 1)
End If
hCreated(UBound(hCreated)) = hTT
End Sub
Public Sub SetToolTip(objTT As Object, sTipText As String, Optional BKColor As Long = &HEEFFFF, Optional TxtColor As Long = vbBlack, Optional MaxWidth As Long = 300, Optional DelayTime As Long = 500, Optional VisibleTime As Long = 2000, Optional bCenter As Boolean = False)
Dim TI As TOOLINFO
With TI
GetClientRect objTT.hwnd, .cRect
.hwnd = objTT.hwnd
.uFlags = TTF_IDISHWND Or TTF_SUBCLASS
If bCenter Then
.uFlags = .uFlags Or TTF_CENTERTIP
End If
.uId = objTT.hwnd
.lpszText = sTipText
.cbSize = Len(TI)
End With
SendMessageLong hTT, TTM_SETMAXTIPWIDTH, 0, MaxWidth
SendMessageLong hTT, TTM_SETDELAYTIME, TTDT_INITIAL, DelayTime
SendMessageLong hTT, TTM_SETDELAYTIME, TTDT_AUTOPOP, VisibleTime
SendMessageLong hTT, TTM_SETTIPTEXTCOLOR, TxtColor, 0&
SendMessageLong hTT, TTM_SETTIPBKCOLOR, BKColor, 0&
SendMessage hTT, TTM_ADDTOOL, 0, TI
End Sub
Public Sub DestroyTT()
If Not bCreated Then Exit Sub
Dim i As Integer
For i = 0 To UBound(hCreated)
DestroyWindow hCreated(i)
Next
End Sub
然后在要加入ToolTip的窗体的Form_load事件中加上
CreateTTWindow Me.hwnd
在Form_unload中加上
DestroyTT
在需要设置控件ToolTip的地方使用
SetToolTip ListBox1, "hello " & vbCrLf & "lenrry "
