Option Explicit
Private Enum EnumItemType
None
Range
Shape
End Enum
Private Type POINTAPI
x As Long
y As Long
End Type
Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As Long
Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As Long) As Long
Private Declare PtrSafe Function GetCursorPos Lib "user32.dll" (ByRef lpPoint As POINTAPI) As Long
Private targets As Dictionary
Public Sub StopTicking()
KillTimer Application.hwnd, 1
End Sub
Sub StartTicking(targets As Dictionary, pollingInterval As Long)
Set Module1.targets = targets
SetTimer Application.hwnd, 1, pollingInterval, AddressOf TickTock
End Sub
Public Sub TickTock(ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal idEvent As LongPtr, ByVal dwTime As Long)
On Error Resume Next
Static previousRange As Range
Static previousShape As Shape
Static previousTarget As EnumItemType
Dim currentTarget As Variant
Dim currentRange As Range
Dim currentShape As Shape
Dim pt As POINTAPI
Dim lNum As Integer
GetCursorPos pt
Set currentTarget = ActiveWindow.RangeFromPoint(pt.x, pt.y)
If currentTarget Is Nothing Then
If previousTarget = EnumItemType.Range Then
Call ActiveSheet.CellLeave(previousRange)
ElseIf previousTarget = EnumItemType.Shape Then
Call ActiveSheet.ShapeLeave(previousShape)
End If
previousTarget = None
Else
If TypeOf currentTarget Is Range Then
Set currentRange = currentTarget
If previousTarget = EnumItemType.Range Then
If currentTarget.Address <> previousRange.Address Then
Call ActiveSheet.CellLeave(previousRange)
If targets.Exists(currentTarget.Address(0, 0)) Then
Call ActiveSheet.CellEnter(currentRange)
Set previousRange = currentRange
previousTarget = EnumItemType.Range
Else
previousTarget = EnumItemType.None
End If
End If
ElseIf previousTarget = EnumItemType.Shape Then
Call ActiveSheet.ShapeLeave(previousShape)
If targets.Exists(currentTarget.Address(0, 0)) Then
Call ActiveSheet.CellEnter(currentRange)
Set previousRange = currentTarget
previousTarget = EnumItemType.Range
Else
previousTarget = EnumItemType.None
End If
Else
If targets.Exists(currentTarget.Address(0, 0)) Then
Call ActiveSheet.CellEnter(currentRange)
Set previousRange = currentRange
previousTarget = EnumItemType.Range
Else
previousTarget = EnumItemType.None
End If
End If
Else
If previousTarget = EnumItemType.Range Then
Call ActiveSheet.CellLeave(previousRange)
ElseIf previousTarget = EnumItemType.Shape Then
If previousShape.Name <> currentTarget.Name Then Call ActiveSheet.LeaveShape(previousShape)
End If
currentTarget = currentTarget.Name
If targets.Exists(currentTarget) Then
Set currentShape = ActiveSheet.Shapes(currentTarget)
If previousTarget = EnumItemType.Shape Then
If currentShape.Name <> previousShape.Name Then
ActiveSheet.ShapeEnter currentShape
Set previousShape = currentShape
previousTarget = EnumItemType.Shape
End If
Else
ActiveSheet.ShapeEnter currentShape
Set previousShape = currentShape
previousTarget = EnumItemType.Shape
End If
Else
previousTarget = EnumItemType.None
End If
End If
End If
End Sub