实现Unicode ToolTipText

imperialeast

让tooltipText也能支持unicode

Option 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

imperialeast

imperialeast

可以实战的，看图