鼠标移到某控件上,会显示一行说明文字框,但有时框中说明文字太长,如何将其分成二行以上?
解决方案 »
- VB制作聊天程序要知道哪些知识
- GetModuleFileNameEx 函数的问题要用GetModuleFileNameExA来执行的问题
- VB中能否生成柏拉图?
- 请问怎么读取cc08的原始话单(.bil的)文件[高手进]
- 如何用一个按钮的形式,点击能够指向另一台电脑指定的文件夹???
- 为什么我在窗体的icon属性里增加一个ico图标,系统提示无效图片?
- 10分一句话。
- 两个问题:菜单的单选标记怎么加上去,就像IE里查看文字大小里的选项前那个黑圈;lock的文本框怎样屏蔽粘贴按钮
- 哪有IE的繁体字库下载!!!!!!
- 在进销存程序中,如何编写权限管理!
- 窗口变大控件也跟着变大!
- 声明书写问题~~~~~~~~~大虾快来哦!!
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 = 3Public 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 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
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 LongDeclare Sub InitCommonControls Lib "comctl32.dll" ()Public bCreated As Boolean, hTT As Long
Public hCreated() As LongPublic 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 SubPublic 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 SubPublic 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"