Search code examples
vbawinapi

Issue Creating a Tooltip in VBA

I'm trying to create a tooltip in VBA using winapi calls, basically following the tutorial from MSDN remapped to VBA with Declare statements etc. The call to CreateWindowsEx() returns NULL and the follow-on GetLastError() returns 0 as well. I've tried both in Excel and Outlook, but it gives the same result. Is this simply not possible, or is there anything wrong with the parameters I pass to CreateWindowsEx()?

Here is the complete code snippet:

Private Type INITCOMMONCONTROLSEX_REC
  dwSize As Long
  dwICC As Long
End Type

Private Const ICC_WIN95_CLASSES = &HFF

Private Declare PtrSafe Function InitCommonControlsEx Lib "Comctl32.dll" (ByRef icce As INITCOMMONCONTROLSEX_REC) As Long

Private Const WS_EX_TOPMOST As Long = &H8
Private Const WS_POPUP As Long = &H80000000
Private Const TTS_ALWAYSTIP As Long = &H1
Private Const TTS_NOPREFIX As Long = &H2

Private Const TOOLTIPS_CLASS = "tooltips_class32"

Private Declare PtrSafe Function CreateWindowEx Lib "user32.dll" Alias "CreateWindowExA" (dwExStyle As Long, lpClassName As String, 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 LongPtr, ByVal hMenu As LongPtr, _
        ByVal hInstance As LongPtr, lpParam As Any) As LongPtr


Public Sub CreateToolTip()
    Dim ret As Long
    Dim retLng As LongPtr
    
    Dim iccRec As INITCOMMONCONTROLSEX_REC
    iccRec.dwSize = LenB(iccRec)
    iccRec.dwICC = ICC_WIN95_CLASSES
    
    ret = InitCommonControlsEx(iccRec)
        
    Dim hWndTip As LongPtr
    hWndTip = CreateWindowEx(WS_EX_TOPMOST, TOOLTIPS_CLASS, vbNullString, _
        WS_POPUP Or TTS_NOPREFIX Or TTS_ALWAYSTIP, _
        0, 0, 0, 0, 0, 0, 0, ByVal 0)

End Sub
Solution

  • I wrote a class almost 10 years ago that still works and maybe you can play around and change it to your needs. You can examine and see exactly what it does.

    Insert a new class module into your VBA project and call it ToolTip. Add this code:

    Option Explicit

Private Type LOGFONT 'to use with CreateFontIndirect function (https://msdn.microsoft.com/en-us/library/windows/desktop/dd183500%28v=vs.85%29.aspx)
    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 As String * 32
End Type

Private Type RECT 'rectangle type
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Type POINTAPI '2D cartezian point
    X As Long
    Y As Long
End Type

Private Type LOGBRUSH 'to use with CreateBrushIndirect API function (https://msdn.microsoft.com/en-us/library/windows/desktop/dd183487%28v=vs.85%29.aspx)
    lbStyle As Long
    lbColor As Long
    lbHatch As Long
End Type

Private Type PAINTSTRUCT 'to use with BeginPaint, EndPaint API functions
    hDC As Long
    fErase As Long
    rcPaint As RECT
    fRestore As Long
    fIncUpdate As Long
    rgbReserved(32) As Byte
End Type

Private Enum WND_STYLES 'Window Styles (https://msdn.microsoft.com/en-gb/library/windows/desktop/ms632600(v=vs.85).aspx)
    WS_BORDER = &H800000
    WS_CAPTION = &HC00000
    WS_CHILD = &H40000000
    WS_CLIPCHILDREN = &H2000000
    WS_CLIPSIBLINGS = &H4000000
    WS_DISABLED = &H8000000
    WS_DLGFRAME = &H400000
    WS_GROUP = &H20000
    WS_HSCROLL = &H100000
    WS_MAXIMIZE = &H1000000
    WS_MINIMIZE = &H20000000
    WS_OVERLAPPED = &H0&
    WS_POPUP = &H80000000
    WS_SYSMENU = &H80000
    WS_TABSTOP = &H10000
    WS_THICKFRAME = &H40000
    WS_VISIBLE = &H10000000
    WS_VSCROLL = &H200000
End Enum

Private Enum ECS 'Edit Control Styles (https://msdn.microsoft.com/en-us/library/windows/desktop/bb775464%28v=vs.85%29.aspx)
    ES_AUTOHSCROLL = &H80
    ES_AUTOVSCROLL = &H40
    ES_CENTER = &H1
    ES_LEFT = &H0
    ES_LOWERCASE = &H10
    ES_MULTILINE = &H4
    ES_NOHIDESEL = &H100
    ES_OEMCONVERT = &H400
    ES_PASSWORD = &H20
    ES_READONLY = &H800
    ES_RIGHT = &H2
    ES_UPPERCASE = &H8
    ES_WANTRETURN = &H1000
End Enum

Private Enum EXT_WND_STYLES 'Extended Window Styles (https://msdn.microsoft.com/en-gb/library/windows/desktop/ff700543(v=vs.85).aspx)
    WS_EX_ACCEPTFILES = &H10
    WS_EX_APPWINDOW = &H40000
    WS_EX_CLIENTEDGE = &H200
    WS_EX_COMPOSITED = &H2000000
    WS_EX_CONTEXTHELP = &H400
    WS_EX_CONTROLPARENT = &H10000
    WS_EX_DLGMODALFRAME = &H1
    WS_EX_LAYERED = &H80000
    WS_EX_LAYOUTRTL = &H400000
    WS_EX_LEFT = &H0
    WS_EX_LEFTSCROLLBAR = &H4000
    WS_EX_LTRREADING = &H0
    WS_EX_MDICHILD = &H40
    WS_EX_NOACTIVATE = &H8000000
    WS_EX_NOINHERITLAYOUT = &H100000
    WS_EX_NOPARENTNOTIFY = &H4
    WS_EX_NOREDIRECTIONBITMAP = &H200000
    WS_EX_RIGHT = &H1000
    WS_EX_RIGHTSCROLLBAR = &H0
    WS_EX_RTLREADING = &H2000
    WS_EX_STATICEDGE = &H20000
    WS_EX_TOOLWINDOW = &H80
    WS_EX_TOPMOST = &H8
    WS_EX_TRANSPARENT = &H20
    WS_EX_WINDOWEDGE = &H100
    WS_EX_OVERLAPPEDWINDOW = WS_EX_WINDOWEDGE Or WS_EX_CLIENTEDGE
    WS_EX_PALETTEWINDOW = WS_EX_WINDOWEDGE Or WS_EX_TOOLWINDOW Or WS_EX_TOPMOST
End Enum

Private Enum DRAWTEXT_FORMAT 'to use for DrawText function (https://msdn.microsoft.com/en-us/library/windows/desktop/dd162498%28v=vs.85%29.aspx)
    DT_TOP = &H0
    DT_LEFT = &H0
    DT_CENTER = &H1
    DT_RIGHT = &H2
    DT_VCENTER = &H4
    DT_BOTTOM = &H8
    DT_WORDBREAK = &H10
    DT_SINGLELINE = &H20
    DT_EXPANDTABS = &H40
    DT_TABSTOP = &H80
    DT_NOCLIP = &H100
    DT_EXTERNALLEADING = &H200
    DT_CALCRECT = &H400
    DT_NOPREFIX = &H800
    DT_INTERNAL = &H1000
End Enum

Private Enum BK_MODE 'background mode to use with SetBkMode function (https://msdn.microsoft.com/en-us/library/windows/desktop/dd162965(v=vs.85).aspx)
    TRANSPARENT = 1
    OPAQUE = 2
End Enum

Private Enum CHARSET
    ANSI_CHARSET = 0
    ARABIC_CHARSET = 178
    BALTIC_CHARSET = 186
    CHINESEBIG5_CHARSET = 136
    DEFAULT_CHARSET = 1
    EASTEUROPE_CHARSET = 238
    GREEK_CHARSET = 161
    HANGUL_CHARSET = 129
    HEBREW_CHARSET = 177
    JOHAB_CHARSET = 130
    MAC_CHARSET = 77
    OEM_CHARSET = 255
    RUSSIAN_CHARSET = 204
    SHIFTJIS_CHARSET = 128
    SYMBOL_CHARSET = 2
    THAI_CHARSET = 222
    TURKISH_CHARSET = 162
End Enum

Private Enum DRAW_ICON_FLAG 'to use with DrawIconEx function (https://msdn.microsoft.com/en-us/library/windows/desktop/ms648065(v=vs.85).aspx)
    DI_COMPAT = &H4
    DI_DEFAULTSIZE = &H8
    DI_IMAGE = &H2
    DI_MASK = &H1
    DI_NOMIRROR = &H10
    DI_NORMAL = 3 'DI_IMAGE and DI_MASK
End Enum

Private Enum BORDER
    BDR_RAISEDOUTER = &H1
    BDR_SUNKENOUTER = &H2
    BDR_RAISEDINNER = &H4
    BDR_SUNKENINNER = &H8
    BDR_OUTER = &H3
    BDR_INNER = &HC
    BDR_RAISED = &H5
    BDR_SUNKEN = &HA
End Enum

Private Enum EDGE
    EDGE_RAISED = BDR_RAISEDOUTER Or BDR_RAISEDINNER
    EDGE_SUNKEN = BDR_SUNKENOUTER Or BDR_SUNKENINNER
    EDGE_ETCHED = BDR_SUNKENOUTER Or BDR_RAISEDINNER
    EDGE_BUMP = BDR_RAISEDOUTER Or BDR_SUNKENINNER
End Enum

Private Enum EDGE_FLAG
    BF_LEFT = &H1
    BF_TOP = &H2
    BF_RIGHT = &H4
    BF_BOTTOM = &H8
    BF_TOPLEFT = (BF_TOP Or BF_LEFT)
    BF_TOPRIGHT = (BF_TOP Or BF_RIGHT)
    BF_BOTTOMLEFT = (BF_BOTTOM Or BF_LEFT)
    BF_BOTTOMRIGHT = (BF_BOTTOM Or BF_RIGHT)
    BF_RECT = BF_LEFT Or BF_TOP Or BF_RIGHT Or BF_BOTTOM
    BF_DIAGONAL = &H10
    BF_DIAGONAL_ENDTOPRIGHT = (BF_DIAGONAL Or BF_TOP Or BF_RIGHT)
    BF_DIAGONAL_ENDTOPLEFT = (BF_DIAGONAL Or BF_TOP Or BF_LEFT)
    BF_DIAGONAL_ENDBOTTOMLEFT = (BF_DIAGONAL Or BF_BOTTOM Or BF_LEFT)
    BF_DIAGONAL_ENDBOTTOMRIGHT = (BF_DIAGONAL Or BF_BOTTOM Or BF_RIGHT)
    BF_MIDDLE = &H800    ' Fill in the middle
    BF_SOFT = &H1000     ' Use for softer buttons
    BF_ADJUST = &H2000   ' Calculate the space left over
    BF_FLAT = &H4000     ' For flat rather than 3-D borders
    BF_MONO = &H8000     ' For monochrome borders
End Enum

Private Const SC_EDIT = "Edit" 'System Classes (https://msdn.microsoft.com/en-gb/library/windows/desktop/ms633574(v=vs.85).aspx#system)
'
'API functions
#If VBA7 Then
    Private Declare PtrSafe Function BeginPaint Lib "user32" (ByVal hwnd As LongPtr, lpPaint As PAINTSTRUCT) As LongPtr
    Private Declare PtrSafe Function CreateBrushIndirect Lib "gdi32" (lpLogBrush As LOGBRUSH) As LongPtr
    Private Declare PtrSafe Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As LongPtr
    Private Declare PtrSafe 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 LongPtr, ByVal hMenu As LongPtr, ByVal hInstance As LongPtr, lpParam As Any) As LongPtr
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare PtrSafe Function DestroyWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function DrawEdge Lib "user32" (ByVal hDC As LongPtr, qrc As RECT, ByVal EDGE As Long, ByVal grfFlags As Long) As Long
    Private Declare PtrSafe Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hDC As LongPtr, ByVal lpStr As String, ByVal nCount As Long, _
        lpRect As RECT, ByVal wFormat As Long) As Long
    Private Declare PtrSafe Function EndPaint Lib "user32" (ByVal hwnd As LongPtr, lpPaint As PAINTSTRUCT) As Long
    Private Declare PtrSafe Function FillRect Lib "user32" (ByVal hDC As LongPtr, lpRect As RECT, ByVal hBrush As LongPtr) As Long
    Private Declare PtrSafe Function GetClientRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function GetDesktopWindow Lib "user32" () As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hDC As LongPtr) As Long
    Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hDC As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Private Declare PtrSafe Function SetBkMode Lib "gdi32" (ByVal hDC As LongPtr, ByVal nBkMode As Long) As Long
    Private Declare PtrSafe Function SetWindowPos Lib "user32" (ByVal hwnd As LongPtr, ByVal hWndInsertAfter As LongPtr, ByVal X As Long, _
        ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
    Private Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal nCmdShow As Long) As Long
    Private Declare PtrSafe Function DrawIconEx Lib "user32" (ByVal hDC As LongPtr, ByVal xLeft As Long, ByVal yTop As Long, _
        ByVal hIcon As LongPtr, ByVal cxWidth As Long, ByVal cyWidth As Long, ByVal istepIfAniCur As Long, _
        ByVal hbrFlickerFreeDraw As LongPtr, ByVal diFlags As Long) As Long
#Else
    Private Declare Function BeginPaint Lib "User32.dll" (ByVal hwnd As Long, ByRef lpPaint As PAINTSTRUCT) As Long
    Private Declare Function CreateBrushIndirect Lib "gdi32" (lpLogBrush As LOGBRUSH) As Long
    Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
    Private 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
    Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
    Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function DrawEdge Lib "user32" (ByVal hDC As Long, qrc As RECT, ByVal EDGE As Long, ByVal grfFlags As Long) As Long
    Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hDC As Long, ByVal lpStr As String, ByVal nCount As Long, _
        lpRect As RECT, ByVal wFormat As Long) As Long
    Private Declare Function EndPaint Lib "User32.dll" (ByVal hwnd As Long, ByRef lpPaint As PAINTSTRUCT) As Long
    Private Declare Function FillRect Lib "User32.dll" (ByVal hDC As Long, ByRef lpRect As RECT, ByVal hBrush As Long) As Long
    Private Declare Function GetClientRect Lib "User32.dll" (ByVal hwnd As Long, ByRef lpRect As RECT) As Long
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function GetDesktopWindow Lib "user32" () As Long
    Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long
    Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
    Private Declare Function SetBkMode Lib "gdi32" (ByVal hDC As Long, ByVal nBkMode 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 Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
    Private Declare Function DrawIconEx Lib "user32" (ByVal hDC As Long, ByVal xLeft As Long, ByVal yTop As Long, _
        ByVal hIcon As Long, ByVal cxWidth As Long, ByVal cyWidth As Long, ByVal istepIfAniCur As Long, _
        ByVal hbrFlickerFreeDraw As Long, ByVal diFlags As Long) As Long
#End If

'handles
#If VBA7 Then
    Private m_hWndToolTip As LongPtr 'handle for window
    Private m_hDCToolTip As LongPtr  'handle for device context
    Private m_hIcon As LongPtr       'handle for Icon
#Else
    Private m_hWndToolTip As Long
    Private m_hDCToolTip As Long
    Private m_hIcon As Long
#End If

'primary class members
Private m_objParent As Object
Private m_font As LOGFONT
Private m_strMessage As String

'position and size
Private m_sngLeft As Single
Private m_sngTop As Single
Private m_sngWidth As Single
Private m_sngHeight As Single
Private m_sngOffsetFromCursorX As Single
Private m_sngOffsetFromCursorY As Single
Private m_sngTextOffsetLeft As Single
Private m_sngTextOffsetTop As Single
Private m_sngTextOffsetRight As Single
Private m_sngTextOffsetBottom As Single
Private m_sngIconLeft As Single
Private m_sngIconTop As Single
Private m_sngIconWidth As Single
Private m_sngIconHeight As Single

'visibility
Private m_bVisible As Boolean

'auto resize
Private m_bAutoResize As Boolean

'custom types variables
Private m_tClientAreaRect As RECT
Private m_tLogBrush As LOGBRUSH

'Class constructor with default values
Private Sub Class_Initialize()
    'position, size and visibility
    m_sngLeft = 0
    m_sngTop = 0
    m_sngWidth = 100
    m_sngHeight = 100
    m_sngOffsetFromCursorX = 0
    m_sngOffsetFromCursorY = 0
    m_sngTextOffsetLeft = 10
    m_sngTextOffsetTop = 10
    m_sngTextOffsetRight = 10
    m_sngTextOffsetBottom = 10
    m_sngIconLeft = 0
    m_sngIconTop = 0
    m_sngIconWidth = 0
    m_sngIconHeight = 0
    m_strMessage = vbNullString
    m_bVisible = False
    m_bAutoResize = False
    'font
    With m_font
        .lfFaceName = "Arial" & chr(0)
        .lfHeight = 16
        .lfWidth = 6
        .lfEscapement = 0
        .lfWeight = 0
        .lfItalic = 0
        .lfUnderline = 0
        .lfStrikeOut = 0
        .lfCharSet = CHARSET.DEFAULT_CHARSET
        '.lfOutPrecision
        '.lfClipPrecision
        '.lfQuality
        '.lfPitchAndFamily
    End With
    m_tLogBrush.lbColor = &HE1FFFF 'the usual back color (bright yellow)
    'create toolTip window (child of desktop) and get the window handle
    'Make it work for both AutoCAD and Excel
    #If VBA7 Then
        Dim hWndApp As LongPtr
    #Else
        Dim hWndApp As Long
    #End If
    If InStr(LCase(Application.Name), "autocad") > 0 Then
        hWndApp = Application.hwnd
    ElseIf InStr(LCase(Application.Name), "excel") > 0 Then
        #If VBA7 Then
            hWndApp = Application.HinstancePtr
        #Else
            hWndApp Application.hInstance
        #End If
    Else
        MsgBox "ToolTip class is not set to retrive the Handle for this application!", vbCritical, "hWnd"
        Exit Sub
    End If
    m_hWndToolTip = CreateWindowEx(EXT_WND_STYLES.WS_EX_TOOLWINDOW, SC_EDIT, vbNullString, _
        ECS.ES_MULTILINE + ECS.ES_LEFT + ECS.ES_READONLY + WND_STYLES.WS_CHILD, _
        0, 0, 0, 0, GetDesktopWindow, 0, hWndApp, 0)
    '
    'get the Device Context handle for the toolTip window
    m_hDCToolTip = GetDC(m_hWndToolTip)
End Sub

Private Sub Class_Terminate()
    'release device context
    ReleaseDC m_hWndToolTip, m_hDCToolTip
    'destroy toolTip window
    DestroyWindow m_hWndToolTip
End Sub

Public Property Get Parent() As Object
    Set Parent = m_objParent
End Property
Public Property Let Parent(ByVal objParent As Object)
    Set m_objParent = objParent
End Property

Public Property Get Left() As Single
    Left = m_sngLeft
End Property
Public Property Let Left(ByVal sngLeft As Single)
    m_sngLeft = sngLeft
    Call Position(m_sngLeft, m_sngTop)
End Property

Public Property Get Top() As Single
    Top = m_sngTop
End Property
Public Property Let Top(ByVal sngTop As Single)
    m_sngTop = sngTop
    Call Position(m_sngLeft, m_sngTop)
End Property

Public Property Get Width() As Single
    Width = m_sngWidth
End Property
Public Property Let Width(ByVal sngWidth As Single)
    m_sngWidth = sngWidth
End Property

Public Property Get Height() As Single
    Height = m_sngHeight
End Property
Public Property Let Height(ByVal sngHeight As Single)
    m_sngHeight = sngHeight
End Property

Public Property Get TextOffsetLeft() As Single
    TextOffsetLeft = m_sngTextOffsetLeft
End Property
Public Property Let TextOffsetLeft(ByVal sngTextOffsetLeft As Single)
    m_sngTextOffsetLeft = sngTextOffsetLeft
End Property

Public Property Get TextOffsetTop() As Single
    TextOffsetTop = m_sngTextOffsetTop
End Property
Public Property Let TextOffsetTop(ByVal sngTextOffsetTop As Single)
    m_sngTextOffsetTop = sngTextOffsetTop
End Property

Public Property Get TextOffsetRight() As Single
    TextOffsetRight = m_sngTextOffsetRight
End Property
Public Property Let TextOffsetRight(ByVal sngTextOffsetRight As Single)
    m_sngTextOffsetRight = sngTextOffsetRight
End Property

Public Property Get TextOffsetBottom() As Single
    TextOffsetBottom = m_sngTextOffsetBottom
End Property
Public Property Let TextOffsetBottom(ByVal sngTextOffsetBottom As Single)
    m_sngTextOffsetBottom = sngTextOffsetBottom
End Property

Public Property Get BackColor() As Long
    BackColor = m_tLogBrush.lbColor
End Property
Public Property Let BackColor(ByVal lngBackColor As Long)
    m_tLogBrush.lbColor = lngBackColor
End Property

Public Property Get Message() As String
    Message = m_strMessage
End Property
Public Property Let Message(ByVal strMessage As String)
    Select Case strMessage
        Case vbNullString
            Call Hide
            Exit Property
        Case m_strMessage
            If m_bVisible Then Exit Property
        Case Else
            m_strMessage = strMessage
    End Select
    '
    'declare font
    #If VBA7 Then
        Dim lngFontHWnd As LongPtr
        Dim lngOldFontHWnd As LongPtr
    #Else
        Dim lngFontHWnd As Long
        Dim lngOldFontHWnd As Long
    #End If
    '
    Call show
    'create new font object
    lngFontHWnd = CreateFontIndirect(m_font)
    'remember old font while replacing with new font
    lngOldFontHWnd = SelectObject(m_hDCToolTip, lngFontHWnd)
    'get client rectangle
    GetClientRect m_hWndToolTip, m_tClientAreaRect
    'autoResize by text
    If m_bAutoResize Then
        'get the text rectangle (nothing is drawn by using DT_CALCRECT)
        DrawText m_hDCToolTip, m_strMessage, Len(m_strMessage), m_tClientAreaRect, DRAWTEXT_FORMAT.DT_NOCLIP + _
            DRAWTEXT_FORMAT.DT_LEFT + DRAWTEXT_FORMAT.DT_CALCRECT
        'resize toolTip window
        With m_tClientAreaRect
            m_sngWidth = .Right - .Left + m_sngTextOffsetLeft + m_sngTextOffsetRight
            m_sngHeight = .Bottom - .Top + m_sngTextOffsetTop + m_sngTextOffsetBottom
        End With
        SetWindowPos m_hWndToolTip, 0, m_sngLeft, m_sngTop, m_sngWidth, m_sngHeight, 0
        'get client new rectangle
        GetClientRect m_hWndToolTip, m_tClientAreaRect
    End If
    'draw the colored rectangle into DC
    Call DrawRect
    'draw the edge of the rectangle
    DrawEdge m_hDCToolTip, m_tClientAreaRect, EDGE.EDGE_RAISED, EDGE_FLAG.BF_RECT
    'set background before text placing
    SetBkMode m_hDCToolTip, BK_MODE.TRANSPARENT
    'resize rectangle for placing text and offset-ing text rectangle from main colored rectangle
    With m_tClientAreaRect
        .Left = .Left + m_sngTextOffsetLeft
        .Top = .Top + m_sngTextOffsetTop
        .Right = .Right - m_sngTextOffsetRight
        .Bottom = .Bottom - m_sngTextOffsetBottom
    End With
    'draw the text
    DrawText m_hDCToolTip, m_strMessage, Len(m_strMessage), m_tClientAreaRect, DRAWTEXT_FORMAT.DT_NOCLIP + DRAWTEXT_FORMAT.DT_LEFT
    'selected object [oldFont] releases the previous object of the same type in the Device Context (no memory leaks)
    Call SelectObject(m_hDCToolTip, lngOldFontHWnd)
    'delete new font object
    DeleteObject lngFontHWnd
    'draw icon
    If m_hIcon <> 0 Then
        DrawIconEx m_hDCToolTip, 5, 5, m_hIcon, 16, 16, 0, 0, DRAW_ICON_FLAG.DI_NORMAL
    End If
End Property

Public Sub OffsetFromCursor(ByVal sngOffsetFromCursorX As Single, ByVal sngOffsetFromCursorY As Single)
    m_sngOffsetFromCursorX = sngOffsetFromCursorX
    m_sngOffsetFromCursorY = sngOffsetFromCursorY
End Sub

Public Sub Position(ByVal X As Single, ByVal Y As Single)
    m_sngLeft = X + m_sngOffsetFromCursorX
    m_sngTop = Y + m_sngOffsetFromCursorY
    SetWindowPos m_hWndToolTip, 0, m_sngLeft, m_sngTop, m_sngWidth, m_sngHeight, 0
End Sub

Public Sub PositionByMouse()
    Dim mouseXY As POINTAPI
    GetCursorPos mouseXY
    Position mouseXY.X, mouseXY.Y
End Sub

Public Sub show()
    If Not m_bVisible Then
        Call ShowWindow(m_hWndToolTip, 1)
        m_bVisible = True
    End If
End Sub

Public Sub Hide()
    If m_bVisible Then
        Call ShowWindow(m_hWndToolTip, 0)
        m_bVisible = False
    End If
End Sub

Public Sub DrawRect()
    Dim tPS As PAINTSTRUCT
    'declare brush
    #If VBA7 Then
        Dim lngBrush As LongPtr
    #Else
        Dim lngBrush As Long
    #End If
    '
    On Error Resume Next
    'begin paint
    BeginPaint m_hWndToolTip, tPS
    'create a new brush
    lngBrush = CreateBrushIndirect(m_tLogBrush)
    'fill the device context of the toolTip window with the newly created brush inside the client rectangle
    FillRect m_hDCToolTip, m_tClientAreaRect, lngBrush
    'delete the brush
    Call DeleteObject(lngBrush)
    'end paint
    Call EndPaint(m_hWndToolTip, tPS)
End Sub

Public Property Get Font_Height() As Long
    Font_Height = m_font.lfHeight
End Property
Public Property Let Font_Height(ByVal lngFont_Height As Long)
    m_font.lfHeight = lngFont_Height
End Property

Public Property Get Font_Width() As Long
    Font_Width = m_font.lfWidth
End Property
Public Property Let Font_Width(ByVal lngFont_Width As Long)
    m_font.lfWidth = lngFont_Width
End Property

Public Property Get Font_Text_Rotation() As Long
    Font_Text_Rotation = m_font.lfEscapement
End Property
Public Property Let Font_Text_Rotation(ByVal lngFontTextRotation As Long)
    m_font.lfEscapement = lngFontTextRotation
End Property

Public Property Get Font_Orientation() As Long
    Font_Orientation = m_font.lfOrientation
End Property
Public Property Let Font_Orientation(ByVal lngFont_Orientation As Long)
    m_font.lfOrientation = lngFont_Orientation
End Property

Public Property Get Font_Italic() As Boolean
    Font_Italic = CBool(m_font.lfItalic)
End Property
Public Property Let Font_Italic(ByVal bFontItalic As Boolean)
    m_font.lfItalic = CByte(bFontItalic)
End Property

Public Property Get Font_Underline() As Boolean
    Font_Underline = CBool(m_font.lfUnderline)
End Property
Public Property Let Font_Underline(ByVal bFontUnderline As Boolean)
    m_font.lfUnderline = CByte(bFontUnderline)
End Property

Public Property Get Font_StrikeOut() As Boolean
    Font_StrikeOut = CBool(m_font.lfStrikeOut)
End Property
Public Property Let Font_StrikeOut(ByVal bFontStrikeOut As Boolean)
    m_font.lfStrikeOut = CByte(bFontStrikeOut)
End Property

#If VBA7 Then
    Public Property Let IconHandle(ByVal lngHandle As LongPtr)
        m_hIcon = lngHandle
    End Property
    Public Property Get IconHandle() As LongPtr
        IconHandle = m_hIcon
    End Property
#Else
    Public Property Let IconHandle(ByVal lngHandle As Long)
        m_hIcon = lngHandle
    End Property
    Public Property Get IconHandle() As Long
        IconHandle = m_hIcon
    End Property
#End If

Public Property Get IconLeft() As Single
    IconLeft = m_sngIconLeft
End Property
Public Property Let IconLeft(ByVal sngIconLeft As Single)
    m_sngIconLeft = sngIconLeft
End Property

Public Property Get IconTop() As Single
    IconTop = m_sngIconTop
End Property
Public Property Let IconTop(ByVal sngIconTop As Single)
    m_sngIconTop = sngIconTop
End Property

Public Property Get IconWidth() As Single
    IconWidth = m_sngIconWidth
End Property
Public Property Let IconWidth(ByVal sngIconWidth As Single)
    m_sngIconWidth = sngIconWidth
End Property

Public Property Get IconHeight() As Single
    IconHeight = m_sngIconHeight
End Property
Public Property Let IconHeight(ByVal sngIconHeight As Single)
    m_sngIconHeight = sngIconHeight
End Property

Public Property Get AutoResize() As Boolean
    AutoResize = m_bAutoResize
End Property
Public Property Let AutoResize(ByVal bAutoResize As Boolean)
    m_bAutoResize = bAutoResize
End Property

    This is a simple code to test. Add this to a standard code module:

    Option Explicit

Private m_toolTip As ToolTip

Sub TestToolTip()
    Set m_toolTip = New ToolTip
    With m_toolTip
        .AutoResize = True
        .OffsetFromCursor 30, 0
        .PositionByMouse
        .Message = .Left & ", " & .Top & vbNewLine & "These are the mouse coordinates!"
    End With
End Sub

Sub TestToolTip2()
    If m_toolTip Is Nothing Then TestToolTip
    m_toolTip.Message = Join(Split("Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum.", ". "), "." & vbNewLine)
End Sub

Sub TerminateTooltip()
    Set m_toolTip = Nothing
End Sub

    When you run one of the two test procedures a tooltip will appear. When you run the terminate procedure the tooltip will dissapear.

    You can of course have a control mouse move event on a userform or on a chart or maybe a timer that makes the tooltip move around and update all the time but I am sure you will be able to adapt it.

    The code I wrote does not use the control you were trying to use in your question but rather builds everything from scratch. Regardless, I hope this is helpful.