实现Unicode ToolTipText
让tooltipText也能支持unicodeOption Explicit
Private Declare Function SendMessageW Lib "user32" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function CreateWindowExW Lib "user32" (ByVal dwExStyle As Long, ByVal lpClassName As Long, ByVal lpWindowName As Long, 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, ByVal lpParam As Long) As Long
Private Declare Function GetClientRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Private Declare Function DestroyWindow Lib "user32" (ByVal hWnd As Long) As Long
Private Const WS_POPUP = &H80000000
Private Const TTS_ALWAYSTIP = &H1
Private Const TTS_NOPREFIX = &H2
Private Const TTM_ADDTOOL = &H400 + 50 ' &H432
Private Const TTM_UPDATETIPTEXTW = &H400 + 51 ' &H433（之前的核心错误！）
Private Const TTF_IDISHWND = &H1
Private Const TTF_SUBCLASS = &H10 ' 关键：让 ToolTip 自动响应鼠标
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type TOOLINFOW
cbSize As Long
uFlags As Long
hWnd As Long
uId As Long
RECT As RECT
hInst As Long
lpszText As Long
lParam As Long
End Type
Private Const WM_USER As Long = &H400
Private Const TTM_ACTIVATE As Long = (&H400 + 1)
Private Const TTM_SETDELAYTIME As Long = (&H400 + 3)'add Time
'Private Const TTM_ADDTOOL As Long = (&H400 + 4)
Private Const TTM_DELETETOOL As Long = (&H400 + 5)'TTM_DELTOOL
Private Const TTM_UPDATETIPTEXT As Long = (&H400 + 12)
Private Const TTM_GETTOOLCOUNT As Long = (&H400 + 13)'Get Tip Count
Private Const TTM_ENUMTOOLS As Long = (&H400 + 14) 'add Enum
Private Const TTM_SETTIPBKCOLOR As Long = (&H400 + 19)
Private Const TTM_SETTIPTEXTCOLOR As Long = (&H400 + 20)
Private Const TTM_SETMAXTIPWIDTH As Long = (&H400 + 24)
Private Const TTM_SETMAXTIPHEIGHT As Long = (&H400 + 27)
Private Const TTM_SETTITLE As Long = (&H400 + 32)
'Private Const TTS_ALWAYSTIP As Long = &H1
'Private Const TTS_NOPREFIX As Long = &H2
Private Const TTS_NOANIMATE As Long = &H10
Private Const TTS_NOFADE As Long = &H20
Private Const TTS_BALLOON As Long = &H40
Private Const TTS_CLOSE As Long = &H80
'Private Const TTF_IDISHWND As Long = &H1
'Private Const TTF_SUBCLASS As Long = &H10
Private Const WS_EX_TOPMOST As Long = &H8&
'Private Const WS_POPUP As Long = &H80000000
Private Const SWP_NOMOVE As Long = &H2
Private Const SWP_NOSIZE As Long = &H1
Private Const SWP_NOACTIVATE As Long = &H10
Private Const CW_USEDEFAULT As Long = &H80000000
Private Const HWND_NOTOPMOST As Long = -2
Private Const HWND_TOPMOST As Long = -1
Private Const TOOLTIPS_CLASSA As String = "tooltips_class32"
Public Enum TipMark
Errs = 3
Exc = 2
Tip = 1
End Enum
Public hWndT As Long
Private T As TOOLINFOW
Public Function CreateToolTipW(ByVal hWnd As Long, ByVal CtrlhWnd As Long, ByVal uTipText As Long, ByVal hInstance As Long, _
Optional ByVal uTitle As String, Optional ByVal ForeColor As Long, _
Optional ByVal BackColor As Long) As Boolean
hWndT = CreateWindowExW(0, StrPtr("tooltips_class32"), 0, WS_POPUP Or TTS_ALWAYSTIP Or TTS_NOPREFIX, 0, 0, 0, 0, hWnd, 0, hInstance, 0)'TTS_BALLOON
AddTitle hWndT, uTitle
With T
.cbSize = Len(T)
.uFlags = TTF_IDISHWND Or TTF_SUBCLASS ' 关键：自动捕获鼠标事件
.hWnd = hWnd
.uId = CtrlhWnd
End With
GetClientRect CtrlhWnd, T.RECT
T.lpszText = uTipText
If SendMessageW(hWndT, TTM_ADDTOOL, 0, T) Then
Activate hWndT
SetTipColor ForeColor, BackColor
CreateToolTipW = True
Else
CreateToolTipW = False
End If
Exit Function
Ex:
CreateToolTipW = False
End Function
Public Function RemoveTool(ByVal hWnd As Long) As Long
Dim T As TOOLINFOW
Dim Rtn As Long, I As Long
If hWndT = 0 Then: RemoveTool = -1: Exit Function
On Error GoTo Ex
T.cbSize = Len(T)
For I = 0 To SendMessageW(hWndT, TTM_GETTOOLCOUNT, 0, 0) - 1
If SendMessageW(hWndT, TTM_ENUMTOOLS, I, T) Then
If hWnd = T.uId Then
SendMessageW hWndT, TTM_DELETETOOL, 0&, T
RemoveTool = 1
Exit Function
End If
End If
Next
Ex:
RemoveTool = -1
End Function
Public Function SetTipText(ByVal CtlhWnd As Long, ByVal uTipText As Long, Optional ByVal uTitle As String) As Long
Dim Rtn As Long
On Error GoTo Ex
If hWndT = 0 Then
SetTipText = -1
Exit Function
Else
If uTitle <> "" Then
AddTitle hWndT, uTitle
Else
DeleteTitle hWndT
End If
Rtn = AddTool(hWndT, CtlhWnd, uTipText)
End If
SetTipText = Rtn
Exit Function
Ex:
SetTipText = -1
End Function
Public Sub SetTipColor(ByVal ForeColor As Long, ByVal BackColor As Long)
If ForeColor = 0 And BackColor = 0 Then
SetBackColor hWndT, &HE7FDFE
SetTextColor hWndT, 0
Else
SetBackColor hWndT, BackColor
SetTextColor hWndT, ForeColor
End If
End Sub
Private Sub Activate(ByVal hWnd As Long)
SendMessageW hWnd, TTM_ACTIVATE, 1, ByVal 0&
End Sub
Private Function AddTool(ByVal hWnd As Long, ByVal uhWnd As Long, ByVal TipText As Long) As Boolean
Dim RC As RECT
With T
.cbSize = Len(T)
.uFlags = TTF_SUBCLASS Or TTF_IDISHWND
.hWnd = uhWnd
.hInst = 4194304
.uId = uhWnd
.lpszText = TipText
.RECT = RC
End With
GetClientRect uhWnd, RC
AddTool = CBool(SendMessageW(hWnd, TTM_ADDTOOL, 0&, T))
End Function
Private Sub DeActivate(ByVal hWnd As Long)
SendMessageW hWnd, TTM_ACTIVATE, 0, ByVal 0&
End Sub
Public Sub DelToolTip()
If hWndT <> 0 Then
DestroyWindow hWndT
hWndT = 0
End If
End Sub
Private Sub SetBackColor(ByVal hWnd As Long, ByVal dwColour As Long)
SendMessageW hWnd, TTM_SETTIPBKCOLOR, dwColour, ByVal 0&
End Sub
Private Sub SetMaxWidth(ByVal hWnd As Long, ByVal dwWidth As Long)
SendMessageW hWnd, TTM_SETMAXTIPWIDTH, 0, ByVal dwWidth
End Sub
Private Sub SetTextColor(ByVal hWnd As Long, ByVal dwColour As Long)
SendMessageW hWnd, TTM_SETTIPTEXTCOLOR, dwColour, ByVal 0&
End Sub
Private Sub AddTitle(ByVal hWnd As Long, ByVal TipTitle As String)
SendMessageW hWnd, TTM_SETTITLE, Len(TipTitle), ByVal StrPtr(TipTitle)
End Sub
Private Sub DeleteTitle(ByVal hWnd As Long)
SendMessageW hWnd, TTM_SETTITLE, 0&, ByVal StrPtr(vbNullString)
End Sub
Public Function hWndGet() As Long
hWndGet = hWndT
End Function
Public Sub SetDelay(ByVal hWnd As Long, ByVal NewValue As Long)
SendMessageW hWnd, TTM_SETDELAYTIME, 0&, ByVal NewValue
End Sub
Public Sub UpdateText(ByVal uhWnd As Long, ByVal uText As Long)
With T
.cbSize = Len(T)
.hWnd = uhWnd
.uId = uhWnd
.lpszText = uText
End With
SendMessageW hWndT, TTM_UPDATETIPTEXT, 0&, T
End Sub
https://www.0xaa55.com/static/image/common/emp.gif 可以实战的，看图
页:
[1]