WithEvents for a Shape

tiredofit

Well-known Member
Joined
Apr 11, 2013
Messages
1,621
Office Version
  1. 2019
Platform
  1. Windows
I am trying to find an event for a shape but this does not work:


Code:
Public WithEvents ShapesEvent As Shapes


because VBA doesn't recognise Shapes.


What should I declare it as?


Thanks
 
Last edited:

Excel Facts

How can you automate Excel?
Press Alt+F11 from Windows Excel to open the Visual Basic for Applications (VBA) editor.

shg

MrExcel MVP
Joined
May 7, 2008
Messages
21,833
Office Version
  1. 2010
Platform
  1. Windows
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

Well-known Member
Joined
Apr 11, 2013
Messages
1,621
Office Version
  1. 2019
Platform
  1. Windows

shg

MrExcel MVP
Joined
May 7, 2008
Messages
21,833
Office Version
  1. 2010
Platform
  1. Windows
Rory would be the guy to ask.
 

RoryA

MrExcel MVP, Moderator
Joined
May 2, 2008
Messages
38,820
Office Version
  1. 365
  2. 2019
  3. 2016
  4. 2010
Platform
  1. Windows
  2. MacOS

ADVERTISEMENT

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

tiredofit

Well-known Member
Joined
Apr 11, 2013
Messages
1,621
Office Version
  1. 2019
Platform
  1. Windows
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?
 
Last edited:

mikerickson

MrExcel MVP
Joined
Jan 15, 2007
Messages
24,210

ADVERTISEMENT

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
Code:
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
 

Jaafar Tribak

Well-known Member
Joined
Dec 5, 2002
Messages
8,613
Office Version
  1. 2016
Platform
  1. Windows
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 :
Code:
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:
Code:
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

Well-known Member
Joined
Apr 4, 2009
Messages
3,680
@ Jaafar

Well Done !!!

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

Excel contains over 450 functions, with more added every year. That’s a huge number, so where should you start? Right here with this bundle.

Forum statistics

Threads
1,164,628
Messages
5,838,447
Members
430,549
Latest member
jayjay2022

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top