Jaafar Tribak
Well-known Member
- Joined
- Dec 5, 2002
- Messages
- 9,797
- Office Version
- 2016
- Platform
- 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)
2- Code Usage Example ( Standard Module )
Code written and tested in Excel 2016 x64bit - Win10 x64bit.
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 Sub2- 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 SubCode written and tested in Excel 2016 x64bit - Win10 x64bit.
Last edited:
