WithEvents for a Shape

tiredofit

Well-known Member
Joined
Apr 11, 2013
Messages
1,259
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:

Some videos you may like

Excel Facts

Links? Where??
If Excel says you have links but you can't find them, go to Formulas, Name Manager. Look for old links to dead workbooks & delete.

shg

MrExcel MVP
Joined
May 7, 2008
Messages
21,770
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,259

shg

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

RoryA

MrExcel MVP, Moderator
Joined
May 2, 2008
Messages
35,523
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,259
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
23,788

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
7,939
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)
 

Watch MrExcel Video

Forum statistics

Threads
1,109,492
Messages
5,529,173
Members
409,854
Latest member
rickcoba
Top