WithEvents for a Shape

[tiredofit]

I am trying to find an event for a shape but this does not work:

Public WithEvents ShapesEvent As Shapes

because VBA doesn't recognise Shapes.


What should I declare it as?


Thanks

 

[shg]

Shapes don't have events in the object model; they do have an OnAction property.

I saw a Com add-in that may do what you want, but know nothing about it.

 

[tiredofit]

Shapes don't have events in the object model; they do have an OnAction property.

I saw a Com add-in that may do what you want, but know nothing about it.

Maybe I misunderstood RoryA here:

https://www.mrexcel.com/forum/excel-questions/1091216-right-click-event-shape.html

but I am trying to capture right-clicking on a shape and he suggested mousedown, which I assume requires WithEvents.

 

[shg]

Rory would be the guy to ask.

 

[RoryA]

The events don't apply to shapes, they apply to the controls that you are using, like the MSForms.Optionbutton.

 

[tiredofit]

The events don't apply to shapes, they apply to the controls that you are using, like the MSForms.Optionbutton.

So is it possible to capture the right-clicking on a shape and if so, how might I proceed?

 

[mikerickson]

No, you cannot capture the right clicking on a shape
No, you cannot capture right clicking on a control from the Forms menu.
Yes, you can capture the right clicking of a userform control
Yes, you can capture the right clicking of an ActiveX control, with code like

Private Sub TextBox1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If Button = 2 Then
        MsgBox "Right click"
    End If
End Sub

 

[tiredofit]

Thanks for the info.

 

[Jaafar Tribak]

I have just seen this and gave it a shot ... Although I have used a windows timer, I designed the code in such a way it stays stable even if an unhandled error occurs.

Here is workbook demo.


1- Code in a Standard Module :

Option Explicit

Private Type POINTAPI
    x As Long
    y As Long
End Type

Private Type MSG
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
        hwnd As LongPtr
        message As Long
        wParam As LongPtr
        lParam As LongPtr
        time As Long
        pt As POINTAPI
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
        hwnd As Long
        message As Long
        wParam As Long
        lParam As Long
        time As Long
        pt As POINTAPI
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
End Type

[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
    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 PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As MSG, ByVal hwnd As LongPtr, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long
    Private Declare PtrSafe Function WaitMessage Lib "user32" () As Long
    Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As Long
    Private Declare PtrSafe Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
    Private Declare PtrSafe Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr

[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    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 PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As MSG, ByVal hwnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long
    Private Declare Function WaitMessage Lib "user32" () As Long
    Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
    Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
    Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If

Private Const WM_RBUTTONDOWN = &H204
Private Const WM_RBUTTONUP = &H205


Public Sub SetShapesHook()
    [B][COLOR=#008000]'Add right-click macro to shapes 'Rectangle 1','Oval 1','Button 1'[/COLOR][/B]
    If GetProp(Application.hwnd, "HookSet") = 0 Then
        Call HookShape(Sheet1.Shapes("Rectangle 1"), True)
        Call HookShape(Sheet1.Shapes("Oval 1"), True)
        Call HookShape(Sheet1.Shapes("Button 1"), True)
        Call SetProp(Application.hwnd, "HookSet", -1)
        Call StartTimer
    Else
        MsgBox "Right-Click Macro already added to shapes."
    End If
End Sub

Public Sub RemoveShapesHook()
    If GetProp(Application.hwnd, "HookSet") Then
        Call StopTimer
        Call RemoveProp(Application.hwnd, "HookSet")
        Call HookShape(Sheet1.Shapes("Rectangle 1"), False)
        Call HookShape(Sheet1.Shapes("Oval 1"), False)
        Call HookShape(Sheet1.Shapes("Button 1"), False)
    End If
End Sub

Private Sub HookShape(ByVal Shp As Shape, ByVal Hook As Boolean)
    If Hook Then
        Shp.AlternativeText = Shp.AlternativeText & "**" & "Hooked"
    Else
        Shp.AlternativeText = Replace(Shp.AlternativeText, "**" & "Hooked", "")
    End If
End Sub

Private Sub StartTimer()
    Call StopTimer
    SetTimer Application.hwnd, 0, 0, AddressOf TimerProc
End Sub

Private Sub StopTimer()
    KillTimer Application.hwnd, 0
End Sub

Private Sub TimerProc()

    Static bOverShape As Boolean
    Dim tCurPos As POINTAPI, tMsg As MSG
    Dim oShp As Object, sAltText As String
    
    On Error Resume Next
    
    Call StopTimer
    Call GetCursorPos(tCurPos)
    Set oShp = ActiveWindow.RangeFromPoint(tCurPos.x, tCurPos.y)
    If InStr(1, "NothingRangeOLEObject", TypeName(oShp), vbTextCompare) = 0 Then
        sAltText = ActiveSheet.Shapes(oShp.Name).AlternativeText
        If InStr(1, sAltText, "**Hooked", vbTextCompare) Then
            bOverShape = True
            Call WaitMessage
            If PeekMessage(tMsg, Application.hwnd, WM_RBUTTONDOWN, WM_RBUTTONUP, 1) Then
                If GetAsyncKeyState(VBA.vbKeyRButton) Then
                    If bOverShape Then
                        ActiveCell.Select
                    End If
                    Call ThisWorkbook.OnShapeRightClick(oShp)
                End If
            End If
        End If
    End If
    bOverShape = InStr(1, sAltText, "**Hooked", vbTextCompare)
    Call StartTimer

End Sub

2- Code in the ThisWorkbook Module:

Option Explicit

Private Sub Workbook_Open()
 Call SetShapesHook
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
 Call RemoveShapesHook
End Sub


[B][COLOR=#008000]'SHAPES RIGHT-CLICK PSEUDO-EVENT.[/COLOR][/B]
[B][COLOR=#008000]'===============================[/COLOR][/B]
Public Sub OnShapeRightClick(ByVal Shp As Object)
    MsgBox "You Right-Clicked :" & vbNewLine & vbNewLine & Shp.Name, , "Shape Right-Click Pseudo-Event ..."
End Sub

 

[James006]

@ Jaafar

Well Done !!!

It looks like removing the hook is not working as expected ( Windows XP - Excel 2007)