Jaafar Tribak

Well-known Member
Joined
Dec 5, 2002
Messages
9,656
Office Version
  1. 2016
Platform
  1. Windows
Hi dear forum,

I just thought I would post this code here which should accomplish what the tread title suggests. It is similar to the code I posted here for worksheet tabs screentips.

As we know, shapes and buttons placed on worksheets don't have screentips ( Including ActiveX controls ) and I have seen this question come up in many forums like recently here.

I have seen workarounds that consist of attaching hyperlink screentips to the shapes but if we do that , we lose the ability to run the macro attached to the shape. So it is no good.

Here, I am using a vba workaround . It runs ok with no noticeable issues. The code doesn't use timers or sublcassing so it is stable ... Also, the screentips support unicode text and can be added to ActiveX controls as well.


ShapesScreenTips.xlsm








1- CShapeTips (Class Module)
VBA Code:
Option Explicit

'Unicode ScreenTips for Worksheet Shapes.
'Formatted + wav sound.
'Written on 23/November/2022 & MrExcel.com.


Private WithEvents wb As Workbook
Private WithEvents MonitorMouseHover As CommandBars
Private WithEvents MonitorSound As CommandBars

#If Win64 Then
    Private Const NULL_PTR = 0^
#Else
    Private Const NULL_PTR = 0&
#End If


#If VBA7 Then
    #If Win64 Then
        Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal arg1 As LongLong, ppacc As Any, pvarChild As Variant) As Long
    #Else
        Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long
    #End If
    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
    Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr
    Private Declare PtrSafe Function IsWindowVisible Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function IsWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
    Private Declare PtrSafe Sub InitCommonControls Lib "comctl32.dll" ()
    Private Declare PtrSafe Function InitCommonControlsEx Lib "comctl32.dll" (iccex As InitCommonControlsEx) As Long
    Private Declare PtrSafe Function CreateWindowEx Lib "user32" Alias "CreateWindowExW" (ByVal dwExStyle As Long, ByVal lpClassName As LongPtr, ByVal lpWindowName As LongPtr, 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 GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As LongPtr
    Private Declare PtrSafe Function DestroyWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function SendMessage Lib "user32.dll" Alias "SendMessageW" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByRef lParam As Any) As LongPtr
    Private Declare PtrSafe Function SendMessageLong Lib "user32.dll" Alias "SendMessageW" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As LongPtr
    Private Declare PtrSafe Function SetThreadExecutionState Lib "Kernel32.dll" (ByVal esFlags As Long) As Long
    Private Declare PtrSafe Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function TranslateColor Lib "oleAut32.dll" Alias "OleTranslateColor" (ByVal Clr As OLE_COLOR, ByVal palet As LongPtr, col As Long) As Long
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare PtrSafe Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As LongPtr
    Private Declare PtrSafe Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As LongPtr, ByVal nCount As Long, lpObject As Any) As Long
    Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
    Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
    Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
    Private Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
    Private Declare PtrSafe Function GlobalSize Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
    Private Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongPtr) As Long
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare PtrSafe Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" (lpszSoundName As Any, ByVal uFlags As Long) As Long
    Private Declare PtrSafe Function waveOutGetNumDevs Lib "winmm.dll" () As Long
#Else
    Private Enum LongPtr
        [_]
    End Enum
    Private Declare Function AccessibleObjectFromPoint Lib "oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
    Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr
    Private Declare Function IsWindowVisible Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare Function IsWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare Function GetActiveWindow Lib "user32" () As LongPtr
    Private Declare Sub InitCommonControls Lib "comctl32.dll" ()
    Private Declare Function InitCommonControlsEx Lib "comctl32.dll" (iccex As InitCommonControlsEx) As Long
    Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExW" (ByVal dwExStyle As Long, ByVal lpClassName As LongPtr, ByVal lpWindowName As LongPtr, 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 Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As LongPtr
    Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageW" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByRef lParam As Any) As LongPtr
    Private Declare Function SendMessageLong Lib "user32.dll" Alias "SendMessageW" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As LongPtr
    Private Declare Function SetThreadExecutionState Lib "Kernel32.dll" (ByVal esFlags As Long) As Long
    Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare Function TranslateColor Lib "oleAut32.dll" Alias "OleTranslateColor" (ByVal Clr As OLE_COLOR, ByVal palet As LongPtr, col As Long) As Long
    Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As LongPtr
    Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As LongPtr, ByVal nCount As Long, lpObject As Any) As Long
    Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare Function CloseClipboard Lib "user32" () As Long
    Private Declare Function EmptyClipboard Lib "user32" () As Long
    Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
    Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
    Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
    Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongPtr) As Long
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" (lpszSoundName As Any, ByVal uFlags As Long) As Long
    Private Declare Function waveOutGetNumDevs Lib "winmm.dll" () As Long
#End If


Private Type POINTAPI
    x As Long
    y As Long
End Type

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Type InitCommonControlsEx
   Size As Long
   ICC 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  As String * 32
End Type

Private Type TOOLINFOW
    cbSize    As Long
    uFlags    As Long
    hwnd      As LongPtr
    uId       As LongPtr
    cRect     As RECT
    hinst     As LongPtr
    lpszText  As LongPtr
End Type

Private bWavBytesBuffer() As Byte
Private sSheetCodeNamesArray() As String
Private arText() As String
Private arIcon() As ICON_TYPE
Private arTitle() As String
Private arForeColor() As Long
Private arBackColor() As Long
Private arBalloon() As Boolean
Private arFontName() As String
Private arFontSize() As Long
Private arFontBold() As Boolean
Private arPlaySound() As Boolean
Private arRightToLeftReadingOrder() As Boolean
Private arVisibleTime() As Long
 
' change if required.
Private Const EMBEDDED_WAV_OBJECT = "ToolTipSound"
Private Const WAV_OBJECT_PARENT_SHEET = "Sheet2"


Private hFont As LongPtr, hToolTip As LongPtr




'__________________________________________ Class Init\Term Events ________________________________________________
Private Sub Class_Initialize()
    Set wb = ThisWorkbook
End Sub

Private Sub Class_Terminate()
    Call RemoveToolTip
    Set MonitorMouseHover = Nothing
    'Debug.Print "class terminated."
End Sub



'__________________________________________ Public Class Methods _________________________________________________________

Public Sub AddScreenTip( _
    ByVal Sh As Object, _
    ByVal TipText As String, _
    Optional ByVal Icon As ICON_TYPE, _
    Optional ByVal Title As String, _
    Optional ByVal ForeColor As Long = -1&, _
    Optional ByVal BackColor As Long = -1&, _
    Optional ByVal Balloon As Boolean, _
    Optional ByVal FontName As String = "Segoe UI", _
    Optional ByVal FontSize As Long = 12&, _
    Optional ByVal FontBold As Boolean, _
    Optional ByVal PlaySound As Boolean, _
    Optional ByVal RightToLeftReadingOrder As Boolean, _
    Optional ByVal VisibleTime As Long = 5000& _
)

    If (Not sSheetCodeNamesArray) = -1& Then
        ReDim sSheetCodeNamesArray(0&) As String
        ReDim arText(0&) As String
        ReDim arIcon(0&) As ICON_TYPE
        ReDim arTitle(0&) As String
        ReDim arForeColor(0&) As Long
        ReDim arBackColor(0&) As Long
        ReDim arBalloon(0) As Boolean
        ReDim arFontName(0&) As String
        ReDim arFontSize(0&) As Long
        ReDim arFontBold(0&) As Boolean
        ReDim arPlaySound(0&) As Boolean
        ReDim arRightToLeftReadingOrder(0&) As Boolean
        ReDim arVisibleTime(0&)
    Else
        ReDim Preserve sSheetCodeNamesArray(UBound(sSheetCodeNamesArray) + 1&)
        ReDim Preserve arText(UBound(arText) + 1&)
        ReDim Preserve arIcon(UBound(arIcon) + 1&)
        ReDim Preserve arTitle(UBound(arTitle) + 1&)
        ReDim Preserve arForeColor(UBound(arForeColor) + 1&)
        ReDim Preserve arBackColor(UBound(arBackColor) + 1&)
        ReDim Preserve arBalloon(UBound(arBalloon) + 1&)
        ReDim Preserve arFontName(UBound(arFontName) + 1&)
        ReDim Preserve arFontSize(UBound(arFontSize) + 1&)
        ReDim Preserve arFontBold(UBound(arFontBold) + 1&)
        ReDim Preserve arPlaySound(UBound(arPlaySound) + 1&)
        ReDim Preserve arRightToLeftReadingOrder(UBound(arRightToLeftReadingOrder) + 1&)
        ReDim Preserve arVisibleTime(UBound(arVisibleTime) + 1&)
    End If
 
    sSheetCodeNamesArray(UBound(sSheetCodeNamesArray)) = Sh.Name
    arText(UBound(arText)) = TipText
    arIcon(UBound(arIcon)) = Icon
    arTitle(UBound(arTitle)) = Title
    arForeColor(UBound(arForeColor)) = ForeColor
    arBackColor(UBound(arBackColor)) = BackColor
    arBalloon(UBound(arBalloon)) = Balloon
    arFontName(UBound(arFontName)) = FontName
    arFontSize(UBound(arFontSize)) = FontSize
    arFontBold(UBound(arFontBold)) = FontBold
    arPlaySound(UBound(arPlaySound)) = PlaySound
    arRightToLeftReadingOrder(UBound(arRightToLeftReadingOrder)) = RightToLeftReadingOrder
    arVisibleTime(UBound(arVisibleTime)) = VisibleTime

End Sub

Public Sub Activate()
    If (Not sSheetCodeNamesArray) = -1& Then
        MsgBox "No tooltips have been added yet.", vbCritical
        Exit Sub
    End If
 
    If SoundOleObjectExists Then
        Call BuildSoundArray(Worksheets(WAV_OBJECT_PARENT_SHEET).OLEObjects(EMBEDDED_WAV_OBJECT))
    Else
        MsgBox "wav object missing"
    End If
 
    Set MonitorMouseHover = Application.CommandBars
End Sub




'_______________________________________ Private Class Routines _________________________________________________

Private Sub MonitorMouseHover_OnUpdate()
 
    Static oPrevObj As Object
    Dim tCurPos As POINTAPI
    Dim oCurObj As Object
    Dim indx As Long

    On Error Resume Next
 
    If Not ActiveWorkbook Is ThisWorkbook Then Call RemoveToolTip: GoTo Xit
    If GetActiveWindow <> Application.hwnd Then Call RemoveToolTip: GoTo Xit
 
    Call GetCursorPos(tCurPos)
    Set oCurObj = ActiveWindow.RangeFromPoint(tCurPos.x, tCurPos.y)
 
    If TypeName(oCurObj) = "Range" Or TypeName(oCurObj) = "Nothing" Then
        Call RemoveToolTip
        GoTo Xit
    End If
 
    If oCurObj.Name <> oPrevObj.Name Then
        If Not IsError(Application.Match(oCurObj.Name, sSheetCodeNamesArray, 0&)) Then
            indx = Application.Match(oCurObj.Name, sSheetCodeNamesArray, 0&)
            If indx Then
                indx = indx - 1&
                Call CreateToolTip(arText(indx), arIcon(indx), arTitle(indx), _
                arForeColor(indx), arBackColor(indx), arBalloon(indx), arFontName(indx), _
                arFontSize(indx), arFontBold(indx), arPlaySound(indx), _
                arRightToLeftReadingOrder(indx), arVisibleTime(indx))
            End If
        End If
    End If

Xit:

    Set oPrevObj = oCurObj
 
    With Application.CommandBars.FindControl(ID:=2040&)
        .Enabled = Not .Enabled
    End With
 
    PreventSleepMode = True

End Sub

Private Sub MonitorSound_OnUpdate()
    If IsWindowVisible(hToolTip) Then
        Call PlaySoundNow
        Set MonitorSound = Nothing
    End If
End Sub

Private Function SoundOleObjectExists() As Boolean
    On Error Resume Next
    SoundOleObjectExists = Not IsError(Worksheets(WAV_OBJECT_PARENT_SHEET).OLEObjects(EMBEDDED_WAV_OBJECT))
End Function

Private Sub RemoveToolTip()
    If IsWindow(FindWindow("tooltips_class32", "MyToolTip")) Then
        Call DeleteObject(hFont)
        Call DestroyWindow(FindWindow("tooltips_class32", "MyToolTip"))
'        Debug.Print "Tooltip Destroyed."
    End If
End Sub

Private Property Let PreventSleepMode(ByVal bPrevent As Boolean)
    Const ES_SYSTEM_REQUIRED As Long = &H1
    Const ES_DISPLAY_REQUIRED As Long = &H2
    Const ES_AWAYMODE_REQUIRED = &H40
    Const ES_CONTINUOUS As Long = &H80000000
 
    If bPrevent Then
        Call SetThreadExecutionState(ES_CONTINUOUS Or ES_DISPLAY_REQUIRED Or ES_SYSTEM_REQUIRED Or ES_AWAYMODE_REQUIRED)
    Else
        Call SetThreadExecutionState(ES_CONTINUOUS)
    End If
End Property

Private Sub CreateToolTip( _
        ByVal TipText As String, _
        ByVal Icon As Long, _
        ByVal Title As String, _
        ByVal ForeColor As Long, _
        ByVal BackColor As Long, _
        ByVal Balloon As Boolean, _
        ByVal FontName As String, _
        ByVal FontSize As Long, _
        ByVal FontBold As Boolean, _
        ByVal PlaySound As Boolean, _
        ByVal RightToLeftReadingOrder As Boolean, _
        ByVal VisibleTime As Long _
    )
                      
        Const TOOLTIPS_CLASSA = "tooltips_class32"
        Const ICC_WIN95_CLASSES = &HFF
        Const CW_USEDEFAULT = &H80000000
        Const WS_EX_NOACTIVATE = &H8000000
        Const WS_EX_LAYOUTRTL = &H400000
        Const WM_USER = &H400
        Const TTM_ADDTOOLW = WM_USER + 4&
        Const TTM_SETDELAYTIME = WM_USER + 3&
        Const TTM_UPDATETIPTEXTW = WM_USER + 57&
        Const TTM_SETTIPBKCOLOR = WM_USER + 19&
        Const TTM_SETTIPTEXTCOLOR = WM_USER + 20&
        Const TTM_SETTITLE = WM_USER + 32&
        Const TTM_TRACKACTIVATE = (WM_USER + 17&)
        Const TTM_TRACKPOSITION = (WM_USER + 18&)
        Const TTS_NOPREFIX = &H2
        Const TTS_BALLOON = &H40
        Const TTS_ALWAYSTIP = &H1
        Const TTF_IDISHWND = &H1
        Const TTF_SUBCLASS = &H10
        Const TTF_TRACK = &H20
        Const TTF_CENTERTIP = &H2
        Const TTDT_AUTOPOP = &H2
        Const WM_SETFONT = &H30
        Const WM_GETFONT = &H31
        Const COLOR_INFOBK = 24&
    
  
        Static bCommonControlsInitialized As Boolean
        Dim lWinStyle As Long, lWinExStyle As Long, lRealColor As Long
        Dim uTTInfo As TOOLINFOW, tIccex As InitCommonControlsEx, tFont As LOGFONT, tCurPos As POINTAPI
        Dim hParent As LongPtr
 
 
        If Not bCommonControlsInitialized Then
            With tIccex
                .Size = LenB(tIccex)
                .ICC = ICC_WIN95_CLASSES
            End With
            If InitCommonControlsEx(tIccex) = False Then
                Call InitCommonControls
            End If
            bCommonControlsInitialized = True
        End If
 
        Call RemoveToolTip
    
        lWinExStyle = WS_EX_NOACTIVATE + IIf(RightToLeftReadingOrder, WS_EX_LAYOUTRTL, 0&)
        lWinStyle = TTS_ALWAYSTIP Or TTS_NOPREFIX
        If Balloon Then lWinStyle = lWinStyle Or TTS_BALLOON
        hToolTip = CreateWindowEx(lWinExStyle, ByVal StrPtr(TOOLTIPS_CLASSA), ByVal StrPtr("MyToolTip"), _
                    lWinStyle, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, _
                    NULL_PTR, NULL_PTR, GetModuleHandle(vbNullString), ByVal 0&)
                
        hFont = SendMessage(hToolTip, WM_GETFONT, NULL_PTR, NULL_PTR)
        Call GetObjectAPI(hFont, LenB(tFont), tFont)
        With tFont
            .lfHeight = -FontSize
            .lfWeight = IIf(FontBold, 800&, .lfWeight)
            .lfFaceName = FontName & vbNullChar
        End With
        Call DeleteObject(hFont)
        hFont = CreateFontIndirect(tFont)
        Call SendMessage(hToolTip, WM_SETFONT, hFont, True)
  
        hParent = FindWindowEx(FindWindowEx(Application.hwnd, NULL_PTR, "XLDESK", vbNullString) _
            , NULL_PTR, "EXCEL7", vbNullString)

        With uTTInfo
            If RightToLeftReadingOrder Then
                .uFlags = TTF_TRACK + TTF_CENTERTIP
            Else
                .uFlags = TTF_SUBCLASS Or TTF_IDISHWND
            End If
            .hwnd = hParent
            .uId = hParent
            .hinst = GetModuleHandle(vbNullString)
            .lpszText = StrPtr(TipText)
            .cbSize = LenB(uTTInfo)
        End With
  
        Call SendMessage(hToolTip, TTM_ADDTOOLW, NULL_PTR, uTTInfo)
        Call SendMessage(hToolTip, TTM_UPDATETIPTEXTW, NULL_PTR, uTTInfo)
  
        If ForeColor <> -1& Then SendMessage hToolTip, TTM_SETTIPTEXTCOLOR, ForeColor, ByVal 0&
        If BackColor <> -1& Then
            Call TranslateColor(BackColor, NULL_PTR, lRealColor)
        Else
            Call TranslateColor(GetSysColor(COLOR_INFOBK), NULL_PTR, lRealColor)
        End If
        Call SendMessage(hToolTip, TTM_SETTIPBKCOLOR, lRealColor, ByVal 0&)
  
        If Icon <> I_NoIcon Or Title <> vbNullString Then _
                Call SendMessage(hToolTip, TTM_SETTITLE, CLng(Icon), ByVal Title)
        Call SendMessageLong(hToolTip, TTM_SETDELAYTIME, TTDT_AUTOPOP, VisibleTime)
    
        If RightToLeftReadingOrder Then
            Call GetCursorPos(tCurPos)
            With tCurPos
                Call SendMessage(hToolTip, TTM_TRACKACTIVATE, True, uTTInfo)
                Call SendMessage(hToolTip, TTM_TRACKPOSITION, ByVal NULL_PTR, ByVal MakeDWord(CInt(.x), CInt(.y)))
            End With
        End If
          
        If PlaySound And SoundOleObjectExists Then
            Set MonitorSound = Application.CommandBars
        End If

End Sub

Private Sub PlaySoundNow()
    Const SND_ASYNC = &H1
    Const SND_NODEFAULT = &H2
    Const SND_MEMORY = &H4
    If waveOutGetNumDevs > 0& Then
        sndPlaySound bWavBytesBuffer(InStr(StrConv(bWavBytesBuffer, vbUnicode), "RIFF") - 1&), _
                    SND_ASYNC Or SND_NODEFAULT Or SND_MEMORY
    End If
 
End Sub

Private Function BuildSoundArray(WAVOleObject As OLEObject) As Boolean

    Const CF_NATIVE = &HC004&
    
    Dim hClipMem As LongPtr, lMemSize As LongPtr, lMemPtr As LongPtr
 
    On Error GoTo Xit

    WAVOleObject.Copy
    DoEvents
    If OpenClipboard(NULL_PTR) Then
        hClipMem = GetClipboardData(CF_NATIVE)
        If hClipMem Then lMemSize = GlobalSize(hClipMem)
        If lMemSize Then lMemPtr = GlobalLock(hClipMem)
        If lMemPtr Then
            ReDim bWavBytesBuffer(0 To CLng(lMemSize) - 1&) As Byte
            Call CopyMemory(bWavBytesBuffer(0&), ByVal lMemPtr, lMemSize)
            If (Not bWavBytesBuffer) = -1& Then
                BuildSoundArray = True
            End If
            Call GlobalUnlock(hClipMem)
        End If
        Call EmptyClipboard
        Call CloseClipboard
    End If
    Exit Function
Xit:
    Call CloseClipboard

End Function

Private Function loword(DWord As Long) As Integer
    If DWord And &H8000& Then
        loword = DWord Or &HFFFF0000
    Else
        loword = DWord And &HFFFF&
    End If
End Function

Private Function hiword(ByVal DWord As Long) As Integer
    hiword = (DWord And &HFFFF0000) \ &H10000
End Function

Private Function MakeDWord(loword As Integer, hiword As Integer) As Long
    MakeDWord = (hiword * &H10000) Or (loword And &HFFFF&)
End Function

Private Sub wb_Deactivate()
    Call RemoveToolTip
End Sub



2- Code Usage Example ( Standard Module )
VBA Code:
Option Explicit

Public Enum ICON_TYPE
    I_NoIcon
    I_Info
    I_Warning
    I_Error
End Enum

Private OScreenTips As CShapeTips

Private Sub Start()

    Set OScreenTips = New CShapeTips
 
    With OScreenTips
 
        .AddScreenTip Sheet1.Buttons("Button 1"), "This is a Multiline ToolTip with Sound." & vbCr & vbCr & "Line2 ..." & _
            vbCr & "Line3 ..." & vbCr & "Line4 ..." & vbCr & "Line5 ..." & vbCr, _
            I_Info, "Title", vbRed, , True, , , , True, , 10000
'
        .AddScreenTip Sheet1.Buttons("Button 2"), "Basic Rectangular Tooltip without any formatting.", , , , , , , , , True
'
        .AddScreenTip Sheet1.Shapes("Oval 1"), "These are 'tooltips_class32' class-based controls" _
            & vbCr & "from the COMCTL32 library.", I_Info, " ", , &HFFFFCC, True, , , , True
'
        .AddScreenTip Sheet1.Shapes("Picture 1"), "Hey, vba coding is fun." & vbCr & _
            "But combining vba with The Win32 api is even more fun !!", I_Info, _
            "Hello MrExcel", vbRed, &HFFE1FF, True, "Old English Text MT", 15, , , , 5000
'
        .AddScreenTip Sheet1.Shapes("TextBox 1"), "This is a formatted Tooltip for : " & vbCr & _
            "TextBox 1", I_Warning, "Tooltip With Sound.", , &H8ED0A9, True, , , , True, , 5000
'
        .AddScreenTip Sheet1.Shapes("Spinner 1"), Sheet2.Range("h1"), I_Info, _
            "Cyrillic russian unicode text taken from Cell H1 in Sheet2.", , &H99FFCC, True, , , , , , 10000
'
        .AddScreenTip Sheet1.Shapes("Rectangle 1"), "Hello World !", I_Error, "WodrArt Shape." _
        , vbWhite, &H535060, True, , , , , , 8000

        .Activate
 
    End With

End Sub

Private Sub Finish()
    Set OScreenTips = Nothing
End Sub

Sub TooggleCheckBox(ByVal bOn As Boolean)
    If bOn Then
        Call Start
    Else
        Call Finish
    End If
End Sub

Private Sub Dummy()
    'dummy sub for embedded wav oleobject located in sheet2.
End Sub

Private Sub Auto_Open()
    Sheet1.CheckBox1.Value = False
    ActiveWindow.RangeSelection.Select
End Sub

Private Sub Auto_Close()
    Call Finish
End Sub

Sub ClickMacro()
    MsgBox "You clicked :" & vbCrLf & "[" & ActiveSheet.Shapes(Application.Caller).Name & "]"
End Sub


Code written and tested in Excel 2016 x64bit - Win10 x64bit.
 
Last edited:

Excel Facts

Copy formula down without changing references
If you have =SUM(F2:F49) in F50; type Alt+' in F51 to copy =SUM(F2:F49) to F51, leaving the formula in edit mode. Change SUM to COUNT.
Hi Jaafar,

I've accomplished something similar by grouping a shape with a normal control such as a activeX button. Do these in the order mentioned
* Make the shape and control the same size
* Push the shape behind the button
* Group Them
* Click on the group
* Right Click on the shape while the group is selected and choose link (this has to be done after they are grouped)
* Add the Screentip and make the link local within the workbook to a cell on a sheet
* Select both the Shape and the button
* Align them top and left
* Now when you hover over the button, the screentip from the shape will show

Jeff
 
Upvote 0
Hi Jaafar,

I've accomplished something similar by grouping a shape with a normal control such as a activeX button. Do these in the order mentioned
* Make the shape and control the same size
* Push the shape behind the button
* Group Them
* Click on the group
* Right Click on the shape while the group is selected and choose link (this has to be done after they are grouped)
* Add the Screentip and make the link local within the workbook to a cell on a sheet
* Select both the Shape and the button
* Align them top and left
* Now when you hover over the button, the screentip from the shape will show

Jeff
Thanks Jeff.

After doing the above, does the shape still run the macro that is asscociated with it when clicking on it ?
 
Upvote 0
Yes . It does work when adding the screentip to the group. Just like you said ... Good to know.

The reason it wasn't working for me earlier on is bacause I was assuming the click macro was also assigned to the shape. (Not to the button)

This is a cool workaround as it can also be applied to shapes and form buttons.

Thank you very much Jeff . (y)
 
Upvote 0
Cool, I'm glad it worked.

Part of the steps I didn't include was that the button should already have the macro attached to it.

The best part is that the shape can be formatted with better looking shadow features that show around the button
 
Upvote 0
2022-12-16_14-02-53.gif


Jess, it required to me 3 clicks to obtain the msgbox the first time and 2 clicks the following times.
Latest Excel Office Insider (Excel® for Microsoft 365 MSO (Version 2212 Build 16.0.15928.20002) 64-bit)
Latest Windows 11.

Now trying the fabulous solutions made by Jaafar.
 
Upvote 0
View attachment 81032

Jess, it required to me 3 clicks to obtain the msgbox the first time and 2 clicks the following times.
Latest Excel Office Insider (Excel® for Microsoft 365 MSO (Version 2212 Build 16.0.15928.20002) 64-bit)
Latest Windows 11.

Now trying the fabulous solutions made by Jaafar.

Jeffrey's workaround worked well for me . I just needed to follow the exact steps he outlined in post#2.
 
Upvote 0

Forum statistics

Threads
1,216,500
Messages
6,131,016
Members
449,615
Latest member
Nic0la

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top