Option Explicit
Private WithEvents MouseMove As CommandBars
Private WithEvents WB As Workbook
Public Enum CursorTypes
IDC_ARROW = 32512
IDC_IBEAM = 32513
IDC_WAIT = 32514
IDC_CROSS = 32515
IDC_UPARROW = 32516
IDC_SIZE = 32640
IDC_ICON = 32641
IDC_SIZENWSE = 32642
IDC_SIZENESW = 32643
IDC_SIZEWE = 32644
IDC_SIZENS = 32645
IDC_SIZEALL = 32646
IDC_NO = 32648
IDC_HAND = 32649
IDC_APPSTARTING = 32650
End Enum
Private Type POINTAPI
x As Long
y As Long
End Type
#If VBA7 Then
Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
Private Declare PtrSafe Function GetCursorPos Lib "user32.dll" (ByRef lpPoint As POINTAPI) As Long
Private Declare PtrSafe Function CopyIcon Lib "user32" (ByVal hIcon As LongPtr) As LongPtr
Private Declare PtrSafe Function DestroyIcon Lib "user32" (ByVal hIcon As LongPtr) As Long
Private Declare PtrSafe Function LoadCursorFromFile Lib "user32" Alias "LoadCursorFromFileA" (ByVal lpFileName As String) As LongPtr
Private Declare PtrSafe Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long
Private Declare PtrSafe Function LoadCursor Lib "user32" Alias "LoadCursorA" (ByVal hInstance As LongPtr, ByVal lpCursorName As Long) As Long
Private Declare PtrSafe Function SetSystemCursor Lib "user32" (ByVal hCur As LongPtr, ByVal id As Long) As Long
Private Declare PtrSafe Function PlaySound Lib "winmm.dll" Alias "PlaySoundA" (ByVal lpszName As String, ByVal hModule As LongPtr, ByVal dwFlags As LongPtr) As LongPtr
#Else
Private Declare Function GetActiveWindow Lib "user32" () As Long
Private Declare Function GetCursorPos Lib "user32.dll" (ByRef lpPoint As POINTAPI) As Long
Private Declare Function CopyIcon Lib "user32" (ByVal hIcon As Long) As Long
Private Declare Function DestroyIcon Lib "user32" (ByVal hIcon As Long) As Long
Private Declare Function LoadCursorFromFile Lib "user32" Alias "LoadCursorFromFileA" (ByVal lpFileName As String) As Long
Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long
Private Declare Function LoadCursor Lib "user32" Alias "LoadCursorA" (ByVal hInstance As Long, ByVal lpCursorName As Long) As Long
Private Declare Function SetSystemCursor Lib "user32" (ByVal hCur As Long, ByVal id As Long) As Long
Private Declare Function PlaySound Lib "winmm.dll" Alias "PlaySoundA" (ByVal lpszName As String, ByVal hModule As Long, ByVal dwFlags As Long) As Long
#End If
Private oTTip As CToolTip
Private sShapeName As String
Private sWavFile As String
Private sCursorFile As String
Private oShpeObj As Object
Private sngLeft As Single, sngTop As Single
Private sngWidth As Single, sngHeight As Single
Private eSystemCursor As CursorTypes
Private oCursorImage As Object
Private Const SND_FILENAME = &H20000
Private Const SND_ASYNC = &H1
Private Const SND_NODEFAULT = &H2
Private Const SPI_SETCURSORS = 87
Private Sub Class_Initialize()
Call RestoreDefaultCursors
Set MouseMove = Application.CommandBars
Call MouseMove_OnUpdate
End Sub
Public Property Get ShapeObject() As Object
Set ShapeObject = oShpeObj
End Property
Public Property Set ShapeObject(ByVal obj As Object)
sngLeft = obj.Left: sngTop = obj.Top
sngWidth = obj.Width: sngHeight = obj.Height
Set oShpeObj = obj
sShapeName = oShpeObj.Name
End Property
Public Property Get Left() As Single
Left = sngLeft
End Property
Public Property Get Top() As Single
Top = sngTop
End Property
Public Property Get Width() As Single
Width = sngWidth
End Property
Public Property Get Height() As Single
Height = sngHeight
End Property
Public Property Get ToolTip() As CToolTip
Set ToolTip = oTTip
Set ToolTip.AssociatedShape = oShpeObj
End Property
Public Property Set ToolTip(obj As CToolTip)
Set oTTip = obj
End Property
Public Property Get ShapeName() As String
ShapeName = sShapeName
End Property
Public Property Get GetWavFile() As String
GetWavFile = sWavFile
End Property
Public Sub PlayWAV(ByVal WavFile As String)
Dim oFolder As Object
If Len(Dir(WavFile)) = 0 Then
Set oFolder = CreateObject("Scripting.FileSystemObject").GetFolder(Environ("SystemRoot") & "\Media")
WavFile = oFolder.Path & "\" & WavFile
End If
If Len(Dir(WavFile)) Then
If PlaySound(WavFile, 0&, SND_ASYNC Or SND_NODEFAULT Or SND_FILENAME) Then
sWavFile = WavFile
End If
End If
End Sub
Public Property Get SystemCursor() As CursorTypes
SystemCursor = eSystemCursor
End Property
Public Property Let SystemCursor(ByVal CurID As CursorTypes)
#If VBA7 Then
Dim hIcon As LongPtr
#Else
Dim hIcon As Long
#End If
Dim arCurs As Variant, i As Long
arCurs = Array(IDC_ARROW, IDC_IBEAM, IDC_WAIT, IDC_CROSS, IDC_UPARROW, IDC_SIZE, IDC_ICON, IDC_SIZENWSE, IDC_SIZENESW, IDC_SIZEWE, IDC_SIZENS, IDC_SIZEALL, IDC_NO, IDC_HAND, IDC_APPSTARTING)
For i = LBound(arCurs) To UBound(arCurs)
hIcon = CopyIcon(LoadCursor(0&, CurID))
If hIcon Then
Call SetSystemCursor(hIcon, arCurs(i))
DestroyIcon hIcon
End If
Next
eSystemCursor = CurID
End Property
Public Property Get CursorFile() As String
sCursorFile = CursorFile
End Property
Public Property Let CursorFile(ByVal IconFile As String)
#If VBA7 Then
Dim hIcon As LongPtr
#Else
Dim hIcon As Long
#End If
Dim arCurs As Variant, i As Long
arCurs = Array(IDC_ARROW, IDC_IBEAM, IDC_WAIT, IDC_CROSS, IDC_UPARROW, IDC_SIZE, IDC_ICON, IDC_SIZENWSE, IDC_SIZENESW, IDC_SIZEWE, IDC_SIZENS, IDC_SIZEALL, IDC_NO, IDC_HAND, IDC_APPSTARTING)
For i = LBound(arCurs) To UBound(arCurs)
hIcon = CopyIcon(LoadCursorFromFile(IconFile))
If hIcon Then
Call SetSystemCursor(hIcon, arCurs(i))
DestroyIcon hIcon
End If
Next
sCursorFile = IconFile
End Property
Public Property Get CursorImage() As Object
Set CursorImage = oCursorImage
End Property
Public Property Set CursorImage(ByVal IconImage As Object)
#If VBA7 Then
Dim hIcon As LongPtr, hPic As LongPtr
#Else
Dim hIcon As Long, hPic As Long
#End If
Dim arCurs As Variant, oPic As Object, i As Long
arCurs = Array(IDC_ARROW, IDC_IBEAM, IDC_WAIT, IDC_CROSS, IDC_UPARROW, IDC_SIZE, IDC_ICON, IDC_SIZENWSE, IDC_SIZENESW, IDC_SIZEWE, IDC_SIZENS, IDC_SIZEALL, IDC_NO, IDC_HAND, IDC_APPSTARTING)
On Error Resume Next
Set oPic = CallByName(IconImage, "Picture", VbGet) ' <== takes into account excel version.
hPic = CallByName(oPic, "Handle", VbGet)
On Error GoTo 0
If hPic Then
For i = LBound(arCurs) To UBound(arCurs)
hIcon = CopyIcon(hPic)
If hIcon Then
Call SetSystemCursor(hIcon, arCurs(i))
DestroyIcon hIcon
Set oCursorImage = IconImage
End If
Next
End If
End Property
Public Sub ToolTipDestroy()
Dim shp As Shape
Call RestoreDefaultCursors
For Each shp In oShpeObj.Parent.Shapes
If shp.AlternativeText = "@^\`|" Then
shp.Delete
End If
Next shp
Set oShpeObj = Nothing
End Sub
Private Sub MouseMove_OnUpdate()
Static oShape As CShapeMouseMoveEvents
Static oPrevObj As Object
Dim oCurObj As Variant
Dim tCurPos As POINTAPI
If GetActiveWindow <> Application.hwnd Then Exit Sub
On Error Resume Next
GetCursorPos tCurPos
Set oCurObj = ActiveWindow.RangeFromPoint(tCurPos.x, tCurPos.y)
If oCurObj.Name <> ShapeName Then
Call ToolTipDestroy
End If
If InStr(1, "RangeNothing", TypeName(oCurObj)) = 0 Then
If Not oPrevObj Is Nothing Then
If oCurObj.Name <> oPrevObj.Name Then
Set oShape = Me
Set oTTip = New CToolTip
Set oShape.ShapeObject = oCurObj
Call ThisWorkbook.ShapeMouseEnter(oShape)
End If
End If
Else
If Not oPrevObj Is Nothing Then
If InStr(1, "RangeNothing", TypeName(oPrevObj)) = 0 Then
If InStr(1, "RangeNothing", TypeName(oCurObj)) Then
If Not oShape Is Nothing Then
Call SystemParametersInfo(SPI_SETCURSORS, 0, 0, 0)
Call ToolTipDestroy
Call ThisWorkbook.ShapeMouseLeave(oShape)
Call ReleaseVars
End If
End If
End If
End If
End If
Set oPrevObj = oCurObj
With Application.CommandBars.FindControl(id:=2020): .Enabled = Not .Enabled: End With
End Sub
Private Sub RestoreDefaultCursors()
Call SystemParametersInfo(SPI_SETCURSORS, 0, 0, 0)
End Sub
Private Sub ReleaseVars()
sShapeName = ""
sWavFile = ""
sCursorFile = ""
Set oShpeObj = Nothing
sngLeft = 0: sngTop = 0
sngWidth = 0: sngHeight = 0
eSystemCursor = 0
Set oCursorImage = Nothing
End Sub
Private Sub WB_BeforeClose(Cancel As Boolean)
Call RestoreDefaultCursors 'Safety net !!.
End Sub