VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "cUniToolTips"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' SubClass related
#Const ImplNoIdeProtection = (MST_NO_IDE_PROTECTION <> 0)
#Const ImplSelfContained = True
Private Const MEM_COMMIT                    As Long = &H1000
Private Const PAGE_EXECUTE_READWRITE        As Long = &H40
Private Const SIGN_BIT                      As Long = &H80000000
Private Const PTR_SIZE                      As Long = 4
Private Const EBMODE_DESIGN                 As Long = 0

Private Declare Sub CopyMemoryR Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function VirtualAlloc Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal flAllocationType As Long, ByVal flProtect As Long) As Long
Private Declare Function CallWindowProcA Lib "user32" (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 GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function GetProcByOrdinal Lib "kernel32" Alias "GetProcAddress" (ByVal hModule As Long, ByVal lpProcOrdinal As Long) As Long
Private Declare Function DefSubclassProc Lib "comctl32" Alias "#413" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long
Private Declare Function FindWindowExA Lib "user32" (ByVal hwndParent As Long, ByVal hWndChildAfter As Long, ByVal lpszClass As String, ByVal lpszWindow As String) As Long
#If ImplSelfContained Then
    Private Declare Function GetEnvironmentVariable Lib "kernel32" Alias "GetEnvironmentVariableA" (ByVal lpName As String, ByVal lpBuffer As String, ByVal nSize As Long) As Long
    Private Declare Function SetEnvironmentVariable Lib "kernel32" Alias "SetEnvironmentVariableA" (ByVal lpName As String, ByVal lpValue As String) As Long
#End If

Private m_pSubclass         As IUnknown

Private Declare Function GetACP Lib "kernel32.dll" () As Long
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 CallWindowProcW Lib "user32" (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 Sub CopyMemoryV Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As Long, ByVal Source As Long, 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 FindWindowExW Lib "user32.dll" (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 Declare Function WideCharToMultiByte Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long, ByVal lpMultiByteStr As Long, ByVal cchMultiByte As Long, ByVal lpDefaultChar As Long, ByVal lpUsedDefaultChar As Long) As Long

Private Const MEM_RELEASE                   As Long = &H8000&
Private Declare Function CryptStringToBinary Lib "crypt32" Alias "CryptStringToBinaryW" (ByVal pszString As Long, ByVal cchString As Long, ByVal dwFlags As Long, ByVal pbBinary As Long, ByRef pcbBinary As Long, ByRef pdwSkip As Long, ByRef pdwFlags As Long) As Long
Private Declare Function VirtualFree Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal dwFreeType As Long) As Long
Private Declare Function VirtualProtect Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal flNewProtect As Long, ByRef lpflOldProtect As Long) As Long
Private Declare Sub GetMem4 Lib "msvbvm60" (ByVal Addr As Long, RetVal As Long)
Private Declare Function DispCallFunc Lib "oleaut32.dll" (ByVal pvInstance As Long, ByVal offsetinVft As Long, ByVal CallConv As Long, ByVal retTYP As Integer, ByVal paCNT As Long, ByVal paTypes As Long, ByVal paValues As Long, ByRef retVAR As Variant) 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 CP_UTF8 As Long = 65001

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

Private mMaxWidth As Long                                                                     ' Maximum tooltip width (0 = infinite)

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
Dim hComThunk As Long

Property Get MaxWidth() As Long
MaxWidth = mMaxWidth
End Property

Property Let MaxWidth(ByVal v As Long)
mMaxWidth = v
End Property

Private Sub Class_Initialize()
Dim cw As CWPSTRUCT
If hComThunk = 0 Then hComThunk = ComWrapperThunk(InitAddressOfMethod(Me, 3).CallWndProc(0, 0, 0), 3)
HookTTT
End Sub

Private Sub Class_Terminate()
If hComThunk Then FreeThunk hComThunk: hComThunk = 0
UnhookTTT
End Sub

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

Private Function toMultiByte(s As String, Optional ByVal CodePage As Long = CP_UTF8) As String
Dim sz As Long
Dim flag As Long
sz = WideCharToMultiByte(CodePage, flag, StrPtr(s), Len(s), 0, 0, 0, 0)
If sz = 0 Then Exit Function
PutMem4 VarPtr(toMultiByte), SysAllocStringByteLen(0, sz)
sz = WideCharToMultiByte(CodePage, flag, StrPtr(s), Len(s), StrPtr(toMultiByte), sz, 0, 0)
End Function

Property Let UniTTT(ctl As Control, ttt As String)
SetUniTTT ctl, ttt
End Property

Property Get UniTTT(ctl As Control) As String
Attribute UniTTT.VB_UserMemId = 0
UniTTT = RestoreUniTTT(ctl.ToolTipText, 0)
End Property

Sub SetUniTTT(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 RestoreUniTTT(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 RestoreUniTTT = ttt: Exit Function
Alignment = Val(Mid$(ttt, 2, 1))
hMem = Val(Mid$(ttt, 3))
If hMem = 0 Then Exit Function
sz = lstrlenW(hMem)
RestoreUniTTT = AllocStr(sz)
lstrcpyW StrPtr(RestoreUniTTT), hMem
End Function

Private Function HookTTT() As Boolean
Dim par As NONCLIENTMETRICS
Dim cw As CWPSTRUCT
'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
    If hComThunk = 0 Then hComThunk = ComWrapperThunk(InitAddressOfMethod(Me, 3).CallWndProc(0, 0, 0), 3)
    hHook = SetWindowsHookEx(WH_CALLWNDPROC, hComThunk, App.hInstance, App.ThreadID) ' Set hook to windows creation
    'If hHook = 0 Or hHook = -1 Then AddLog "No Hook"
    Exit Function
End If
HookTTT = True                                                                         ' Success
End Function

Private Sub UnhookTTT(Optional ByVal Force As Boolean = False)
mCount = mCount - 1
pvUnsubclass
If hHook Then UnhookWindowsHookEx hHook: hHook = 0
If hFont Then DeleteObject hFont: hFont = 0
End Sub

Public Sub UniToolTipUnloadForm(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 UniTTT(ctl) = ""
    On Error GoTo 0
Next
End Sub

Public Sub UniToolTipLoadForm(frm As Form, Optional ByVal CP As Long = 1255)
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 = toMultiByte(ttt, GetACP): ttt = toUnicode(StrPtr(ttt), LenB(ttt), CP): UniTTT(ctl) = ttt
    On Error GoTo 0
Next
End Sub

Private Function InitThunk(HexThunk) As Long
Dim sz As Long
sz = Len(HexThunk) \ 2
InitThunk = VirtualAlloc(0, sz, MEM_COMMIT, PAGE_EXECUTE_READWRITE)
CryptStringToBinary StrPtr(HexThunk), sz + sz, 4, InitThunk, sz, 0, 0
End Function

Private Sub FreeThunk(ByVal hThunk As Long)
VirtualFree hThunk, 0, MEM_RELEASE
End Sub

Private Function HexByte(ByVal n As Long) As String
Dim hx As String
hx = Hex(n)
If Len(hx) = 1 Then hx = "0" & hx
HexByte = hx
End Function

Private Function HexLong(ByVal n As Long) As String
Dim a(4) As Byte
Dim i As Long
Dim s As String
CopyMemoryV VarPtr(a(0)), VarPtr(n), 4
For i = 0 To 3
  s = s & HexByte(a(i))
Next
HexLong = s
End Function

Private Function ComWrapperThunk(ByVal fnPtr As Long, ByVal NumArgs As Long) As Long
Dim sThunk As String
Dim i As Long
sThunk = sThunk & "5589E583EC048D43FC50"
For i = 1 To NumArgs
  sThunk = sThunk & "FF75" & HexByte((NumArgs - i) * 4 + 8)
Next
sThunk = sThunk & "68" & HexLong(ObjPtr(Me))
sThunk = sThunk & "B8" & HexLong(fnPtr)
sThunk = sThunk & "FFD08B45FC89EC5DC2"
sThunk = sThunk & HexByte(NumArgs * 4) & "00"
ComWrapperThunk = InitThunk(sThunk)
End Function

Public Function CallWndProc(ByVal uCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Static clas(0 To 512) As Byte
Dim cw As CWPSTRUCT
CopyMemory cw, ByVal lParam, Len(cw)

If uCode = HC_ACTION Then
    If cw.message = WM_SETTEXT Then                                                 ' Before tooltip is showed it receives WM_SETTEXT
        l = GetClassNameW(cw.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 = cw.hwnd                                                  ' Save tooltip handle
                pvSubclass ToolHwnd
                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

Public Function SubclassProc(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long, Handled As Boolean) 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 wMsg
    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 = RestoreUniTTT(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 mMaxWidth > 32 And w > mMaxWidth Then                                          ' If width is greater than specified
                SetRect rc, bw * 2, bh * 2, mMaxWidth, 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
            SubclassProc = 1                                                               ' 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
        'Debug.Print wp.Y;
        wp.cx = w: wp.cy = h                                                                ' Assign the width and height which we got
        'hIcon = GetCursor()                                                                 ' Get current cursor handle
        'GetIconInfo hIcon, ii                                                               ' Get cursor info
        'GetObject ii.hbmColor, Len(bm), bm                                                  ' Get cursor picture info
        'bw = (bm.bmWidth + ii.xHotspot) \ 2                                                 ' Calculate half-offset to window
        'bh = (bm.bmHeight + ii.yHotspot) \ 2
        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
        'If pt.X + w + bw > Screen.Width \ Screen.TwipsPerPixelX Then                        ' If window is out of bounds
        '    wp.X = pt.X - w - bw                                                            ' Correct position
        '    If wp.X < 0 Then wp.X = 0
        'Else                                                                                ' //
        '    wp.X = pt.X + bw                                                                ' //
        'End If
        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
        'Debug.Print wp.Y
        'If pt.Y + h + bh > Screen.Height \ Screen.TwipsPerPixelY Then                       ' //
        '    wp.Y = pt.Y - h - bh                                                            ' //
        '    If wp.Y < 0 Then wp.Y = 0
        'Else                                                                                ' //
        '    wp.Y = pt.Y + bh                                                                ' //
        'End If
        
        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
    
    If Not Handled And ThunkPrivateData(m_pSubclass) = EBMODE_DESIGN Then
        Handled = True
        SubclassProc = DefSubclassProc(hwnd, wMsg, wParam, lParam)
    End If
End Function


Private Sub pvSubclass(ByVal wnd As Long)
    Set m_pSubclass = InitSubclassingThunk(wnd, Me, InitAddressOfMethod(Me, 5).SubclassProc(0, 0, 0, 0, 0))
End Sub

Private Sub pvUnsubclass()
    TerminateSubclassingThunk m_pSubclass, Me
End Sub

Private Function InitAddressOfMethod(pObj As Object, ByVal MethodParamCount As Long) As cUniToolTips
    Dim STR_THUNK       As String: STR_THUNK = "6AAAAABag+oFV4v6ge9QEMEAgcekEcEAuP9EJAS5+QcAAPOri8LB4AgFuQAAAKuLwsHoGAUAjYEAq7gIAAArq7hEJASLq7hJCIsEq7iBi1Qkq4tEJAzB4AIFCIkCM6uLRCQMweASBcDCCACriTrHQgQBAAAAi0QkCIsAiUIIi0QkEIlCDIHqUBDBAIvCBTwRwQCri8IFUBHBAKuLwgVgEcEAq4vCBYQRwQCri8IFjBHBAKuLwgWUEcEAq4vCBZwRwQCri8IFpBHBALn5BwAAq4PABOL6i8dfgcJQEMEAi0wkEIkRK8LCEAAPHwCLVCQE/0IEi0QkDIkQM8DCDABmkItUJAT/QgSLQgTCBAAPHwCLVCQE/0oEi0IEg/gAfgPCBABZWotCDGgAgAAAagBSUf/gZpC4AUAAgMIIALgBQACAwhAAuAFAAIDCGAC4AUAAgMIkAA==" ' 25.3.2019 14:01:08
    Const THUNK_SIZE    As Long = 16728
    Dim hThunk          As Long
    Dim lSize           As Long
    
    hThunk = pvThunkAllocate(STR_THUNK, THUNK_SIZE)
    If hThunk = 0 Then
        Exit Function
    End If
    lSize = CallWindowProcA(hThunk, ObjPtr(pObj), MethodParamCount, GetProcAddress(GetModuleHandle("kernel32"), "VirtualFree"), VarPtr(InitAddressOfMethod))
    Debug.Assert lSize = THUNK_SIZE
End Function

Private Function InitSubclassingThunk(ByVal hwnd As Long, pObj As Object, ByVal pfnCallback As Long) As IUnknown
    Dim STR_THUNK       As String: STR_THUNK = "6AAAAABag+oFgepwEBAAV1aLdCQUg8YIgz4AdC+L+oHHKBIQAIvCBQwREACri8IFSBEQAKuLwgVYERAAq4vCBYAREACruQkAAADzpYHCKBIQAFJqHP9SEFqL+IvCq7gBAAAAqzPAq4tEJAyri3QkFKWlM8Crg+8cagBX/3IM/3cM/1IYi0QkGIk4Xl+4XBIQAC1wEBAAwhAADx8Ai0QkCIM4AHUqg3gEAHUkgXgIwAAAAHUbgXgMAAAARnUSi1QkBP9CBItEJAyJEDPAwgwAuAJAAIDCDACQi1QkBP9CBItCBMIEAA8fAItUJAT/SgSLQgR1GIsKUv9xDP9yDP9RHItUJASLClL/URQzwMIEAJBVi+yLVRj/QgT/QhiLQhg7QgR0b4tCEIXAdGiLCotBLIXAdDdS/9BaiUIIg/gBd1OFwHUJgX0MAwIAAHRGiwpS/1EwWoXAdTuLClJq8P9xJP9RKFqpAAAACHUoUjPAUFCNRCQEUI1EJARQ/3UU/3UQ/3UM/3UI/3IQ/1IUWVhahcl1E1KLCv91FP91EP91DP91CP9RIFr/ShhQUug4////WF3CGAAPHwA=" ' 9.6.2020 13:56:03
    Const THUNK_SIZE    As Long = 492
    Static hThunk       As Long
    Dim aParams(0 To 10) As Long
    Dim lSize           As Long
    
    aParams(0) = ObjPtr(pObj)
    aParams(1) = pfnCallback
    #If ImplSelfContained Then
        If hThunk = 0 Then
            hThunk = pvThunkGlobalData("InitSubclassingThunk")
        End If
    #End If
    If hThunk = 0 Then
        hThunk = pvThunkAllocate(STR_THUNK, THUNK_SIZE)
        If hThunk = 0 Then
            Exit Function
        End If
        aParams(2) = GetProcAddress(GetModuleHandle("ole32"), "CoTaskMemAlloc")
        aParams(3) = GetProcAddress(GetModuleHandle("ole32"), "CoTaskMemFree")
        Call DefSubclassProc(0, 0, 0, 0)                                            '--- load comctl32
        aParams(4) = GetProcByOrdinal(GetModuleHandle("comctl32"), 410)             '--- 410 = SetWindowSubclass ordinal
        aParams(5) = GetProcByOrdinal(GetModuleHandle("comctl32"), 412)             '--- 412 = RemoveWindowSubclass ordinal
        aParams(6) = GetProcByOrdinal(GetModuleHandle("comctl32"), 413)             '--- 413 = DefSubclassProc ordinal
        '--- for IDE protection
        Debug.Assert pvThunkIdeOwner(aParams(7))
        If aParams(7) <> 0 Then
            aParams(8) = GetProcAddress(GetModuleHandle("user32"), "GetWindowLongA")
            aParams(9) = GetProcAddress(GetModuleHandle("vba6"), "EbMode")
            aParams(10) = GetProcAddress(GetModuleHandle("vba6"), "EbIsResetting")
        End If
        #If ImplSelfContained Then
            pvThunkGlobalData("InitSubclassingThunk") = hThunk
        #End If
    End If
    lSize = CallWindowProcA(hThunk, hwnd, 0, VarPtr(aParams(0)), VarPtr(InitSubclassingThunk))
    Debug.Assert lSize = THUNK_SIZE
End Function

Private Function TerminateSubclassingThunk(pSubclass As IUnknown, pObj As Object) As IUnknown
    If Not pSubclass Is Nothing Then
        Debug.Assert ThunkPrivateData(pSubclass, 2) = ObjPtr(pObj)
        ThunkPrivateData(pSubclass, 2) = 0
        Set pSubclass = Nothing
    End If
End Function

Property Get ThunkPrivateData(pThunk As IUnknown, Optional ByVal index As Long) As Long
    Dim lPtr            As Long
    
    lPtr = ObjPtr(pThunk)
    If lPtr <> 0 Then
        Call CopyMemoryR(ThunkPrivateData, ByVal (lPtr Xor SIGN_BIT) + 8 + index * 4 Xor SIGN_BIT, PTR_SIZE)
    End If
End Property

Property Let ThunkPrivateData(pThunk As IUnknown, Optional ByVal index As Long, ByVal lValue As Long)
    Dim lPtr            As Long
    
    lPtr = ObjPtr(pThunk)
    If lPtr <> 0 Then
        Call CopyMemoryR(ByVal (lPtr Xor SIGN_BIT) + 8 + index * 4 Xor SIGN_BIT, lValue, PTR_SIZE)
    End If
End Property

Private Function pvThunkIdeOwner(hIdeOwner As Long) As Boolean
    #If Not ImplNoIdeProtection Then
        Dim lProcessId      As Long
        
        Do
            hIdeOwner = FindWindowExA(0, hIdeOwner, "IDEOwner", vbNullString)
            Call GetWindowThreadProcessId(hIdeOwner, VarPtr(lProcessId))
        Loop While hIdeOwner <> 0 And lProcessId <> GetCurrentProcessId()
    #End If
    pvThunkIdeOwner = True
End Function

Private Function pvThunkAllocate(sText As String, Optional ByVal Size As Long) As Long
    Static Map(0 To &H3FF) As Long
    Dim baInput()       As Byte
    Dim lIdx            As Long
    Dim lChar           As Long
    Dim lPtr            As Long
    
    pvThunkAllocate = VirtualAlloc(0, IIf(Size > 0, Size, (Len(sText) \ 4) * 3), MEM_COMMIT, PAGE_EXECUTE_READWRITE)
    If pvThunkAllocate = 0 Then
        Exit Function
    End If
    '--- init decoding maps
    If Map(65) = 0 Then
        baInput = StrConv("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/", vbFromUnicode)
        For lIdx = 0 To UBound(baInput)
            lChar = baInput(lIdx)
            Map(&H0 + lChar) = lIdx * (2 ^ 2)
            Map(&H100 + lChar) = (lIdx And &H30) \ (2 ^ 4) Or (lIdx And &HF) * (2 ^ 12)
            Map(&H200 + lChar) = (lIdx And &H3) * (2 ^ 22) Or (lIdx And &H3C) * (2 ^ 6)
            Map(&H300 + lChar) = lIdx * (2 ^ 16)
        Next
    End If
    '--- base64 decode loop
    baInput = StrConv(Replace(Replace(sText, vbCr, vbNullString), vbLf, vbNullString), vbFromUnicode)
    lPtr = pvThunkAllocate
    For lIdx = 0 To UBound(baInput) - 3 Step 4
        lChar = Map(baInput(lIdx + 0)) Or Map(&H100 + baInput(lIdx + 1)) Or Map(&H200 + baInput(lIdx + 2)) Or Map(&H300 + baInput(lIdx + 3))
        Call CopyMemoryR(ByVal lPtr, lChar, 3)
        lPtr = (lPtr Xor SIGN_BIT) + 3 Xor SIGN_BIT
    Next
End Function

#If ImplSelfContained Then
Private Property Get pvThunkGlobalData(sKey As String) As Long
    Dim sBuffer     As String
    
    sBuffer = String$(50, 0)
    Call GetEnvironmentVariable("_MST_GLOBAL" & GetCurrentProcessId() & "_" & sKey, sBuffer, Len(sBuffer) - 1)
    pvThunkGlobalData = Val(Left$(sBuffer, InStr(sBuffer, vbNullChar) - 1))
End Property

Private Property Let pvThunkGlobalData(sKey As String, ByVal lValue As Long)
    Call SetEnvironmentVariable("_MST_GLOBAL" & GetCurrentProcessId() & "_" & sKey, lValue)
End Property
#End If