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 = &H10Public 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 GetClientRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) 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 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 Sub变量DelayTime就是迟延,自己指定 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 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 必须这样,没有别的办法(除非你自己的窗口做提示)
漏了个声明: Declare Sub InitCommonControls Lib "comctl32.dll" ()
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 = &H10Public 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 GetClientRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) 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 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 Sub变量DelayTime就是迟延,自己指定
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 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
必须这样,没有别的办法(除非你自己的窗口做提示)
漏了个声明:
Declare Sub InitCommonControls Lib "comctl32.dll" ()
SetToolTip Command1, "12345", , , , 3000, , True而且,我觉得应该用CallWndHookProc来Hook控件的ToolTip,我原来就是用
SendMessage m_TTWnd, TTM_SETDELAYTIME, TTDT_INITIAL, ByVal 3000
只是不成功,你试过你的代码可行吗?
喂喂喂,先用CreateTTWindow才可以然后再SetToolTip退出之前用DestoryTTWindow
我只想知道到底你试过可行吗?因为我原来的代码机理与你的类似,我想是我的代码某处有问题。
Public bCreated As Boolean, hTT As Long
Public hCreated() As Long
我一直用这段程序。完全正常。原来我也贴过这程序,其他人检验过,很正常。