Shape MouseMove, MouseEnter and MouseLeave Pseudo-Events

[Jaafar Tribak]

Hi all,

Following is a hacky workaround for capturing the above mentioned Mouse events for worksheet shapes.

The code uses the OnUpdate CommandBars event. This event is slow and doesn't fire with fast mouse movements but this is the best I could achieve short of using a Windows timer.

I am not entirely sure this hack will work with all versions although, I think, it should work as expected.

Here is a workbook example

Put the following code in the ThisWorkbook module so that when the workbook is opened, all the shapes located in worksheets(1) will respond to the user's mouse actions.

Option Explicit

Private Type POINTAPI
        x As Long
        y As Long
End Type

#If VBA7 Then
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
#Else
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
#End If

Private WithEvents CmndBrarsEvent As CommandBars

Private Sub Workbook_Open()
    Set CmndBrarsEvent = Application.CommandBars
    ActiveWindow.RangeSelection.Select
End Sub

Private Sub CmndBrarsEvent_OnUpdate()
    Static oPrevShape As Shape
    Dim tPt As POINTAPI
    Dim oShape As Shape
    
    On Error Resume Next
    GetCursorPos tPt
    Set oShape = ActiveSheet.Shapes(ActiveWindow.RangeFromPoint(tPt.x, tPt.y).Name)
    If Not oShape Is Nothing And (oPrevShape Is Nothing) Then
        On Error GoTo 0
        Call Shape_MouseEnter(oShape)
        GoTo Xit
    End If
    If Not oShape Is Nothing Then
        On Error GoTo 0
        Call Shape_MouseMove(oShape, tPt.x, tPt.y)
        GoTo Xit
    End If
    If oShape Is Nothing And Not (oPrevShape Is Nothing) Then
        On Error GoTo 0
        Call Shape_MouseLeave(oPrevShape)
    End If
Xit:
    If TypeName(Selection) = "Range" Then
       ActiveWindow.RangeSelection.Select
    End If
    Set oPrevShape = oShape
End Sub


[B][COLOR=#008000]'=====================
'Mouse events handlers.
'=====================[/COLOR][/B]
Private Sub Shape_MouseEnter(ByVal Shape As Shape)

    If Shape.Parent Is Worksheets(1) Then
        With Shape
            .Fill.ForeColor.RGB = RGB(255, 0, 0)
            If Shape.Type = 1 Then .TextFrame2.TextRange.Text = "ACTIVE"
        End With
        Range("b2") = Shape.Name
    End If

End Sub

Private Sub Shape_MouseLeave(ByVal Shape As Shape)

    If Shape.Parent Is Worksheets(1) Then
        With Shape
            .Fill.ForeColor.RGB = RGB(255, 255, 0)
            If Shape.Type = 1 Then .TextFrame2.TextRange.Text = ""
        End With
        Range("b3") = Shape.Name
        Range("b1").ClearContents
    End If
  
End Sub

Private Sub Shape_MouseMove(ByVal Shape As Shape, ByVal MouseX As Long, MouseY As Long)

    If Shape.Parent Is Worksheets(1) Then
        Range("b1") = Shape.Name
        Range("c1") = "X:=" & MouseX & "    " & "Y:=" & MouseY
    End If
    
End Sub

 

[Jaafar Tribak]

For the sake of completeness, I am posting here a variation of the previous code. This new code uses a Windows Timer (SetTimer API) to allow for faster mouse movements.

I have paid special attention to preventing application crashes in case a compile or runtime error occurs inside the Pseudo-Event handler routines or elsewhere while the timer is executing.

Workbook example

Code to be place in a Standard Module:

Option Explicit

Private Type POINTAPI
        x As Long
        y As Long
End Type

#If VBA7 Then
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal Hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal Hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
    Private Declare PtrSafe Function GetActiveWindow Lib "user32" () 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
#Else
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
    Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
    Private Declare Function GetActiveWindow Lib "user32" () As Long
    Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
#End If


Public Sub RunTest()
  SetTimer hTimerWin, 0, 1, AddressOf TimerProc
End Sub

Public Sub StopTest()
    KillTimer hTimerWin, 0
End Sub


Private Sub TimerProc()
    Static oPrevShape As Shape
    Dim oShape As Shape
    Dim tPt As POINTAPI
 
    On Error Resume Next
    If Application.Hwnd = GetActiveWindow Then
        GetCursorPos tPt
        Set oShape = ActiveSheet.Shapes(ActiveWindow.RangeFromPoint(tPt.x, tPt.y).Name)
        If Not oShape Is Nothing And (oPrevShape Is Nothing) Then
            On Error GoTo 0
            KillTimer hTimerWin, 0
                Call Shape_MouseEnter(oShape)
            SetTimer hTimerWin, 0, 1, AddressOf TimerProc
        End If
        If Not oShape Is Nothing Then
            On Error GoTo 0
            KillTimer hTimerWin, 0
                Call Shape_MouseMove(oShape, tPt.x, tPt.y)
            SetTimer hTimerWin, 0, 1, AddressOf TimerProc
        End If
        If oShape Is Nothing And Not (oPrevShape Is Nothing) Then
            On Error GoTo 0
            KillTimer hTimerWin, 0
                Call Shape_MouseLeave(oPrevShape)
            SetTimer hTimerWin, 0, 1, AddressOf TimerProc
        End If
        Set oPrevShape = oShape
    End If
End Sub


#If VBA7 Then
    Private Function hTimerWin() As LongPtr
#Else
    Private Function hTimerWin() As Long
#End If

        hTimerWin = FindWindowEx(Application.Hwnd, 0, "XLDESK", vbNullString)
        hTimerWin = FindWindowEx(hTimerWin, 0, "EXCEL7", vbNullString)
End Function


[B][COLOR=#008000]'=====================
'Mouse events handlers.
'=====================[/COLOR][/B]
Private Sub Shape_MouseEnter(ByVal Shape As Shape)

    If Shape.Parent Is Worksheets(1) Then
        With Shape
            .Fill.ForeColor.RGB = RGB(255, 0, 0)
            If Shape.Type = 1 Then .TextFrame2.TextRange.Text = "ACTIVE"
        End With
        Range("b2") = Shape.Name
    End If
    
End Sub

Private Sub Shape_MouseLeave(ByVal Shape As Shape)

    If Shape.Parent Is Worksheets(1) Then
        With Shape
            .Fill.ForeColor.RGB = RGB(255, 255, 0)
            If Shape.Type = 1 Then .TextFrame2.TextRange.Text = ""
        End With
        Range("b3") = Shape.Name
        Range("b1").ClearContents
    End If
    
End Sub

Private Sub Shape_MouseMove(ByVal Shape As Shape, ByVal MouseX As Long, MouseY As Long)

    If Shape.Parent Is Worksheets(1) Then
        Range("b1") = Shape.Name
        Range("c1") = "X:=" & MouseX & "    " & "Y:=" & MouseY
    End If
    
End Sub