Attribute VB_Name = "modUniToolTipText"
Option Explicit

' The module for modifying a standard VB tooltip to support multiline text
' The trick, 2013
' unicode support added, 255 characters limit has removed, text alignment also supported
' drybone, 2022

Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, lpvParam As Any, ByVal fuWinIni As Long) As Long
Private Declare Function GetClassNameW Lib "user32" (ByVal hwnd As Long, ByVal lpClassName As Long, ByVal nMaxCount As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongW" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcW" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function DrawText Lib "user32" Alias "DrawTextW" (ByVal hdc As Long, ByVal lpStr As Long, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function lstrcpyW Lib "kernel32" (ByVal lpDest As Long, ByVal lpSrc As Long) As Long
Private Declare Function lstrlenW Lib "kernel32" (ByVal lpString As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function BeginPaint Lib "user32" (ByVal hwnd As Long, lpPaint As PAINTSTRUCT) As Long
Private Declare Function EndPaint Lib "user32" (ByVal hwnd As Long, lpPaint As PAINTSTRUCT) As Long
Private Declare Function OffsetRect Lib "user32" (lpRect As RECT, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
Private Declare Function GetBkMode Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function GetCursor Lib "user32" () As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function GetIconInfo Lib "user32" (ByVal hIcon As Long, piconinfo As ICONINFO) As Long
Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowW" (ByVal lpClassName As Long, ByVal lpWindowName As Long) As Long
Private Declare Function FindWindowEx Lib "user32.dll" Alias "FindWindowExW" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As Long, ByVal lpsz2 As Long) As Long
Private Declare Function GetWindowThreadProcessId Lib "user32.dll" (ByVal hwnd As Long, ByVal lpdwProcessId As Long) As Long
Private Declare Function SysAllocStringLen Lib "oleaut32" (ByVal ptr As Long, ByVal Length As Long) As Long
Private Declare Function SysAllocStringByteLen Lib "oleaut32" (ByVal ptr As Long, ByVal Length As Long) As Long
Private Declare Sub PutMem4 Lib "msvbvm60" (ByVal Addr As Long, ByVal NewVal As Long)
Private Declare Sub GetMem2 Lib "msvbvm60" (ByVal Addr As Long, RetVal As Integer)
Private Declare Function GlobalAlloc Lib "kernel32.dll" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalLock Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Function GlobalFree Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function MultiByteToWideChar Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpMultiByteStr As Long, ByVal cchMultiByte As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long) As Long

Private Const DT_WORDBREAK As Long = &H10
Private Const DT_CENTER As Long = &H1
Private Const DT_CALCRECT As Long = &H400&
Private Const DT_RTLREADING As Long = &H20000
Private Const TRANSPARENT As Long = 1
Private Const SWP_NOACTIVATE As Long = &H10
Private Const SWP_NOZORDER As Long = &H4
Private Const LF_FACESIZE As Long = 32
Private Const SPI_GETNONCLIENTMETRICS As Long = 41
Private Const GWL_WNDPROC As Long = -4&
Private Const WM_SETTEXT As Long = &HC
Private Const WM_SHOWWINDOW As Long = &H18
Private Const WM_GETFONT As Long = &H31
Private Const SM_CXBORDER As Long = 5
Private Const SM_CYBORDER As Long = 6

Private Const WM_WINDOWPOSCHANGING As Long = &H46
Private Const WM_PAINT As Long = &HF
Private Const WH_CALLWNDPROC As Long = 4
Private Const HC_ACTION As Long = 0

Private Type BITMAP
    bmType As Long
    bmWidth As Long
    bmHeight As Long
    bmWidthBytes As Long
    bmPlanes As Integer
    bmBitsPixel As Integer
    bmBits As Long
End Type
Private Type ICONINFO
    fIcon As Long
    xHotspot As Long
    yHotspot As Long
    hBmMask As Long
    hbmColor As Long
End Type
Private Type POINTAPI
    X As Long
    Y As Long
End Type
Private Type RECT
    iLeft As Long
    iTop As Long
    iRight As Long
    iBottom As Long
End Type
Private Type PAINTSTRUCT
    hdc As Long
    fErase As Long
    rcPaint As RECT
    fRestore As Long
    fIncUpdate As Long
    rgbReserved(31) As Byte
End Type
Private Type WINDOWPOS
    hwnd As Long
    hWndInsertAfter As Long
    X As Long
    Y As Long
    cx As Long
    cy As Long
    Flags As Long
End Type
Private Type LOGFONT
    lfHeight As Long
    lfWidth As Long
    lfEscapement As Long
    lfOrientation As Long
    lfWeight As Long
    lfItalic As Byte
    lfUnderline As Byte
    lfStrikeOut As Byte
    lfCharSet As Byte
    lfOutPrecision As Byte
    lfClipPrecision As Byte
    lfQuality As Byte
    lfPitchAndFamily As Byte
    lfFaceName(LF_FACESIZE - 1) As Byte
End Type
Private Type NONCLIENTMETRICS
    cbSize As Long
    iBorderWidth As Long
    iScrollWidth As Long
    iScrollHeight As Long
    iCaptionWidth As Long
    iCaptionHeight As Long
    lfCaptionFont As LOGFONT
    iSMCaptionWidth As Long
    iSMCaptionHeight As Long
    lfSMCaptionFont As LOGFONT
    iMenuWidth As Long
    iMenuHeight As Long
    lfMenuFont As LOGFONT
    lfStatusFont As LOGFONT
    lfMessageFont As LOGFONT
End Type
Private Type CWPSTRUCT
    lParam As Long
    wParam As Long
    message As Long
    hwnd As Long
End Type

Public MaxWidth As Long                                                                     ' Maximum tooltip width (0 = infinite)

Dim lpPrev As Long                                                                          ' Previous window proc
Dim s As String                                                                             '
Dim l As Long
Dim hFont As Long                                                                           ' Font handle of tooltip
Dim RC As RECT                                                                              ' Rectangle of displayed text
Dim w As Long, h As Long                                                                    ' Width and height of tooltip
Dim mAlign As Long
Dim mRTL As Long
Dim ToolHwnd As Long                                                                        ' Tooltip hwnd
Dim hHook As Long                                                                           ' Hook handle
Dim mCount As Long

Private Function AllocStr(ByVal iLen As Long, Optional Characters As Boolean = True) As String
If Characters Then
    PutMem4 VarPtr(AllocStr), SysAllocStringLen(0, iLen)
Else
    PutMem4 VarPtr(AllocStr), SysAllocStringByteLen(0, iLen)
End If
End Function

Private Function toUnicode(ByVal ptr As Long, ByVal nBytes As Long, ByVal CodePage) As String
Dim sz As Long
Dim flag As Long
If nBytes = 0 Or ptr = 0 Then Exit Function
sz = MultiByteToWideChar(CodePage, flag, ptr, nBytes, 0, 0)
If sz = 0 Then Exit Function
toUnicode = String(sz, 0)
MultiByteToWideChar CodePage, flag, ptr, nBytes, StrPtr(toUnicode), sz
End Function

Function FindVBToolTipWindow() As Long
Dim h As Long
Dim clas As String
If App.LogMode = 0 Then clas = "VBBubble" Else clas = "VBBubbleRT6"
h = FindWindow(StrPtr(clas), 0)
While h
    If GetWindowThreadProcessId(h, 0) = App.ThreadID Then FindVBToolTipWindow = h: Exit Function
    h = FindWindowEx(0, h, StrPtr(clas), 0)
Wend
End Function

Property Let UniToolTip(ctl As Control, ttt As String)
SetUniToolTip ctl, ttt
End Property

Property Get UniToolTip(ctl As Control) As String
UniToolTip = RestoreUniToolTip(ctl.ToolTipText, 0)
End Property

Sub SetUniToolTip(ctl As Control, ttt As String, Optional ByVal Alignment As Long)
Dim oldTTT As String
Dim hMem As Long
Dim h As Integer
oldTTT = ctl.ToolTipText
If Len(oldTTT) Then GetMem2 StrPtr(oldTTT), h
If h = 4 Then Call GlobalFree(Val(Mid$(oldTTT, 3)))
If LenB(ttt) = 0 Then ctl.ToolTipText = "": Exit Sub
hMem = GlobalAlloc(0, LenB(ttt) + 2)
CopyMemory ByVal hMem, ByVal StrPtr(ttt), LenB(ttt) + 2
ctl.ToolTipText = ChrW$(4) & CStr(Alignment) & CStr(hMem)
End Sub

Private Function RestoreUniToolTip(ttt As String, Alignment As Long) As String
Dim hMem As Long
Dim sz As Long
Dim h As Integer
Alignment = 0
If Len(ttt) = 0 Then Exit Function
GetMem2 StrPtr(ttt), h
If h <> 4 Then RestoreUniToolTip = ttt: Exit Function
Alignment = Val(Mid$(ttt, 2, 1))
hMem = Val(Mid$(ttt, 3))
If hMem = 0 Then Exit Function
sz = lstrlenW(hMem)
RestoreUniToolTip = AllocStr(sz)
lstrcpyW StrPtr(RestoreUniToolTip), hMem
End Function

' Enable multiline
Public Function HookTTT() As Boolean
Dim par As NONCLIENTMETRICS
'UnhookTTT
mCount = mCount + 1
If hFont = 0 Then
    par.cbSize = Len(par)                                                                   ' Set struct size
    If SystemParametersInfo(SPI_GETNONCLIENTMETRICS, Len(par), par, 0) Then                 ' Get system metrics
        hFont = CreateFontIndirect(par.lfStatusFont)                                        ' Create std system tooltip font
    End If
End If
If hHook Then Exit Function
If ToolHwnd = 0 Then
    'ToolHwnd = FindVBToolTipWindow
    If ToolHwnd = 0 Then
        hHook = SetWindowsHookEx(WH_CALLWNDPROC, AddressOf CallWndProc, App.hInstance, App.ThreadID) ' Set hook to windows creation
        'If hHook = 0 Or hHook = -1 Then AddLog "No Hook"
        Exit Function
    End If
    lpPrev = SetWindowLong(ToolHwnd, GWL_WNDPROC, AddressOf ToolProc)    ' Subclass it
End If
HookTTT = True                                                                         ' Success
End Function

' Disable multiline (you should call it always before close program)
Public Sub UnhookTTT(Optional ByVal Force As Boolean = False)
mCount = mCount - 1
If Force Then mCount = 0
If mCount < 0 Then mCount = 0
If mCount > 0 Then Exit Sub
If ToolHwnd <> 0 And lpPrev <> 0 Then SetWindowLong ToolHwnd, GWL_WNDPROC, lpPrev: ToolHwnd = 0: lpPrev = 0
If hHook Then UnhookWindowsHookEx hHook: hHook = 0
If hFont Then DeleteObject hFont: hFont = 0
End Sub

Public Sub FreeTTT(frm As Form)
Dim ctl As Control
Dim ttt As String
For Each ctl In frm.Controls
    On Error Resume Next
    Err.Clear
    ttt = ctl.ToolTipText
    If Err.Number = 0 And ttt <> "" Then UniToolTip(ctl) = ""
    On Error GoTo 0
Next
End Sub

Public Sub LoadTTT(frm As Form, ByVal CP As Long)
Dim ctl As Control
Dim ttt As String
For Each ctl In frm.Controls
    On Error Resume Next
    Err.Clear
    ttt = ""
    ttt = ctl.ToolTipText
    If Err.Number = 0 And ttt <> "" Then ttt = StrConv(ttt, vbFromUnicode): ttt = toUnicode(StrPtr(ttt), LenB(ttt), CP): UniToolTip(ctl) = ttt
    On Error GoTo 0
Next
End Sub

' Hook procedure
Private Function CallWndProc(ByVal uCode As Long, ByVal wParam As Long, lParam As CWPSTRUCT) As Long
Static clas(0 To 512) As Byte
If uCode = HC_ACTION Then
    If lParam.message = WM_SETTEXT Then                                                 ' Before tooltip is showed it receives WM_SETTEXT
        l = GetClassNameW(lParam.hwnd, VarPtr(clas(0)), 255)                            ' Get class name
        If l Then                                                                       ' If all is ok
            If Left$(clas, 8) = "VBBubble" Then                                         ' Class name 'VBBubble' in IDE, in compiled form - 'VBBubbleRT6'
                ToolHwnd = lParam.hwnd                                                  ' Save tooltip handle
                lpPrev = SetWindowLong(lParam.hwnd, GWL_WNDPROC, AddressOf ToolProc)    ' Subclass it
                CallWndProc = CallNextHookEx(hHook, uCode, wParam, lParam)              ' Continue chain
                UnhookWindowsHookEx hHook                                               ' Uninstall hook
                hHook = 0
                Exit Function
            End If
        End If
    End If
End If
CallWndProc = CallNextHookEx(hHook, uCode, wParam, lParam)                              ' Continue chain
End Function


' Tooltip window proc
Private Function ToolProc(ByVal hwnd As Long, ByVal iMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim ps As PAINTSTRUCT, oft As Long, wp As WINDOWPOS, dc As Long, md As Long, bw As Long, bh As Long
    Dim ii As ICONINFO, bm As BITMAP, pt As POINTAPI, hIcon As Long, scrW As Long, scrH As Long
    
    Select Case iMsg
    Case WM_SETTEXT                                                                         ' Before tooltip is showed it receives WM_SETTEXT
        l = lstrlenW(lParam)                                                                ' Get text length
        If l Then                                                                           ' Check for empty stirng
            s = AllocStr(l)                                                                 ' Allocate enough buffer
            lstrcpyW StrPtr(s), lParam                                                      ' Copy string to buffer
            s = RestoreUniToolTip(s, mAlign)
            If mAlign And 4 Then mRTL = DT_RTLREADING Else mRTL = 0
            mAlign = mAlign And 3
            mAlign = mAlign Or mRTL
            bw = GetSystemMetrics(SM_CXBORDER): bh = GetSystemMetrics(SM_CYBORDER)          ' Get border sizes
            dc = GetDC(0)                                                                   ' Acuire context to calculate string boundaries
            oft = SelectObject(dc, hFont)                                                   ' Select tooltip font
            SetRect RC, 0, 0, 0, 0                                                          ' Reset rectangle of view
            DrawText dc, StrPtr(s), Len(s), RC, mAlign Or DT_CALCRECT                       ' Calculate text boundaries
            OffsetRect RC, bw * 2, bh * 2                                                   ' Offset to double border size
            w = bw * 4 + RC.iRight: h = bh * 4 + RC.iBottom                                 ' Calculate window size
            
            If MaxWidth > 32 And w > MaxWidth Then                                          ' If width is greater than specified
                SetRect RC, bw * 2, bh * 2, MaxWidth, h                                     ' Correct boundaries
                DrawText dc, StrPtr(s), Len(s), RC, mAlign Or DT_CALCRECT Or DT_WORDBREAK   ' Calculate text boundaries taking into account line breaks
                w = bw * 4 + RC.iRight: h = bh * 4 + RC.iBottom                             ' Calculate window size
            End If
            
            SelectObject dc, oft                                                            ' Restore state
            ReleaseDC 0, dc                                                                 ' Release context
            ToolProc = True                                                                 ' Success
            Exit Function
        End If
    Case WM_WINDOWPOSCHANGING                                                               ' Before resizing
        scrW = GetSystemMetrics(0)
        scrH = GetSystemMetrics(1)
        CopyMemory wp, ByVal lParam, Len(wp)                                                ' Get the size and position
        wp.cx = w: wp.cy = h                                                                ' Assign the width and height which we got
        bh = 16
        GetCursorPos pt                                                                     ' Get cursor position
        wp.X = pt.X + bw - w \ 2
        If wp.X + w > scrW Then wp.X = scrW - w
        If wp.X < 0 Then wp.X = 0
        wp.Y = pt.Y + bh
        If wp.Y + h > scrH Then wp.Y = pt.Y - bh - h
        If wp.Y < 0 Then wp.Y = 0
        CopyMemory ByVal lParam, wp, Len(wp)                                                ' Update
        Exit Function
    Case WM_PAINT
        BeginPaint hwnd, ps                                                                 ' Prepare window to redraw
        oft = SelectObject(ps.hdc, hFont)                                                   ' Select font
        SetBkMode ps.hdc, TRANSPARENT                                                       ' Set transparent text background
        DrawText ps.hdc, StrPtr(s), Len(s), RC, mAlign Or DT_WORDBREAK                      ' Draw text with center justifying
        SelectObject ps.hdc, oft                                                            ' Restore font
        EndPaint hwnd, ps                                                                   ' All is done
        Exit Function
    End Select
    ToolProc = CallWindowProc(lpPrev, hwnd, iMsg, wParam, lParam)                            ' Process others by default
End Function