Shape events in VBA

README.MD

Shape Events in Excel VBA

This class implements custom shape events for Excel VBA

Link to stack overflow post where I learnt technique:

https://stackoverflow.com/questions/42442940/excel-vba-shapes-textbox-onchange-event the original sample was implemented in C# as an addin, however is more than doable from VBA also.

https://web.archive.org/web/20140307022328/https://code.msdn.microsoft.com/office/CSExcelNewEventForShapes-0e26b1f2

CShapeEvents.cls

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "stdShapeEvents"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False

'Example.bas
'
'  Dim WithEvents shpEvents As stdShapeEvents
'
'  Sub latchEvents()
'    Set shpEvents = stdShapeEvents.Create(Sheet2)
'    Call shpEvents.HookSheet(Sheet2)
'  End Sub
'
'  Private Sub shpEvents_Changed(shape As shape)
'    Debug.Print shape.Name & " Changed"
'  End Sub
'
'  Private Sub shpEvents_Deselected(shape As shape)
'    Debug.Print shape.Name & " Deselected"
'  End Sub
'
'  Private Sub shpEvents_Selected(shape As shape)
'    Debug.Print shape.Name & " Selected"
'  End Sub
'
'  Private Sub shpEvents_Created(shape As shape)
'    Debug.Print shape.Name & " Created"
'  End Sub
'
'  Private Sub shpEvents_Deleted(ByVal shpName As string)
'    Debug.Print shpName & " Deleted"
'  End Sub
'
'  Private Sub shpEvents_Renamed(shape As shape, ByVal oldName as string)
'    Debug.Print oldName & " renamed to " & shape.name
'  End Sub
'run latchEvents and observe the hooked events in the immediate window.


'TODO:
' * Add Moved(shape as Shape)



Private old_selection As Object
Private WithEvents bars As CommandBars

'Fake events:
Public Event Selected(shp As shape)
Public Event Deselected(shp As shape)
Public Event Changed(shp As shape)
Public Event Created(shp As shape)
Public Event Deleted(ByVal shpName As String)
Public Event Renamed(shp As shape, ByVal oldName As String)

Public SheetShapesDict As Object

Private Sub bars_OnUpdate()
  Dim xSel As Object
  Set xSel = Selection
  
  If isShape(Selection) Or isShape(old_selection) Then
    If Not SheetShapesDict Is Nothing Then
      'Get active sheet codename:
      Dim shtName As String
      shtName = ActiveSheet.CodeName
  
      'Ensure active sheet codename exists in dictionary (via HookSheet)
      If SheetShapesDict.exists(shtName) Then
        'Ensure shape counts are different
        Dim shp As shape
        If SheetShapesDict(shtName)("=COUNT") <> ActiveSheet.Shapes.Count Then
          If SheetShapesDict(shtName)("=COUNT") < ActiveSheet.Shapes.Count Then
            'Shape has been created
            For Each shp In ActiveSheet.Shapes
              If Not SheetShapesDict(shtName).exists(shp.Name) Then
                SheetShapesDict(shtName)("=COUNT") = SheetShapesDict(shtName)("=COUNT") + 1
                Set SheetShapesDict(shtName)(shp.Name) = shp
                RaiseEvent Created(shp)
              End If
            Next
          Else
            'Shape has been deleted
            Dim shpName As Variant
            For Each shpName In SheetShapesDict(shtName).keys()
              Set shp = getShapeByName(ActiveSheet, shpName)
              
              If Left(shpName, 1) <> "=" Then
                If shp Is Nothing Then
                  SheetShapesDict(shtName)("=COUNT") = SheetShapesDict(shtName)("=COUNT") - 1
                  SheetShapesDict(shtName).Remove shpName
                  RaiseEvent Deleted(shpName)
                End If
              End If
            Next
          End If
        Else
          'Shape might have been renamed
          'Identify new name:
          Dim existingShape As shape
          For Each shp In ActiveSheet.Shapes
            If Not SheetShapesDict(shtName).exists(shp.Name) Then
              Set SheetShapesDict(shtName)(shp.Name) = shp
              Set existingShape = shp
            End If
          Next
          For Each shpName In SheetShapesDict(shtName).keys()
            If Left(shpName, 1) <> "=" Then
              Set shp = getShapeByName(ActiveSheet, shpName)
              If shp Is Nothing Then
                SheetShapesDict(shtName).Remove shpName
                RaiseEvent Renamed(existingShape, shpName)
              End If
            End If
          Next
        End If
      End If
    End If
  
  
  
  
    'If selection is a shape then it could have changed or been selected,
    'otherwise if the old selection contained a shape and the new doesn't then
    'shape has been deselected
    If DetectShape(Selection) Then
      'Use the name to decide if it has been changed or selected
      If GetName(old_selection) = GetName(Selection) Then
        'Raise Changed event - doesn't actually imply the shape changed...
        
        'if hash(shp) <> old_hash then ...
          RaiseEvent Changed(Selection.ShapeRange(1))
        'end if
      Else
        'Raise Selected event
        RaiseEvent Selected(Selection.ShapeRange(1))
      End If
    Else
      'Ensure old selection was a shape
      If DetectShape(old_selection) Then
        'If shapeExists(old_selection.ShapeRange) Then
          'Raise Deselected event
          RaiseEvent Deselected(old_selection.ShapeRange(1))
        'End If
      End If
    End If
  End If
  
  'Keep track of old selection
  Set old_selection = Selection
End Sub

Public Sub HookSheet(ByVal sht As Worksheet)
  If SheetShapesDict Is Nothing Then Set SheetShapesDict = CreateObject("Scripting.Dictionary")
  Set SheetShapesDict(sht.CodeName) = CreateObject("Scripting.Dictionary")
  SheetShapesDict(sht.CodeName)("=COUNT") = sht.Shapes.Count
  

  Dim shp As shape
  For Each shp In sht.Shapes
    Set SheetShapesDict(sht.CodeName)(shp.Name) = shp
  Next
End Sub
Public Sub UnhookSheet(ByVal sht as worksheet)
  Call SheetShapesDict.Remove(sht.name)
End Sub
Public Sub UnhookListener()
  set bars = nothing
End Sub

Private Function getShapeByName(sht As Worksheet, ByVal sName As String) As shape
  Dim shp As shape
  For Each shp In sht.Shapes
    If shp.Name = sName Then
      Set getShapeByName = shp
      Exit Function
    End If
  Next
  Set getShapeByName = Nothing
End Function

Private Function GetName(ByVal obj As Object) As String
  On Error Resume Next
  GetName = obj.Name
End Function

Private Function DetectShape(ByVal obj As Object) As Boolean
  On Error GoTo endDetect
    DetectShape = obj.ShapeRange.Count > 0
endDetect:
End Function

Private Function isShape(ByVal obj As Object) As Boolean
  Select Case TypeName(obj)
    Case "Rectangle", "Arc", "Drawing", "Picture"
      isShape = True
    Case Else
      isShape = False
  End Select
End Function

Function ShapeData(shp As shape) As String
  Dim s As String
  
  With shp
    s = .Top & "," & .Left & "," & .Height & "," & .Width & "," & .AlternativeText & "," & .Name
    With .Fill
      s = s & "," & .BackColor.RGB & "," & .ForeColor.RGB
    End With
    With .Line
      s = s & "," & .BackColor.RGB & "," & .ForeColor.RGB
    End With
    s = s & "," & .Glow.Color.RGB
    With .TextFrame2.TextRange
      With .Font.Fill
        s = s & "," & .BackColor.RGB & "," & .ForeColor.RGB
      End With
      s = s & "," & .Text
    End With
  End With
  
  ShapeData = s
End Function

Private Sub Class_Initialize()
  Set bars = Application.CommandBars
End Sub

Example2 - ShapeMoved.bas

Dim sizeDict as object
Dim withevents Shapes as stdShapeEvents

Sub InitialiseEvents()
  set Shapes = new stdShapeEvents
  set sizeDict = CreateObject("Scripting.Dictionary")
  for each shp in activesheet.shapes
    'Detect change in position / size
    sizeDict(shp.Name) = GetSize(shp)
  next
End Sub

Sub Shapes_Changed(shp as shape)
  if GetSize(shp) <> sizeDict(shp.Name) then
    debug.print "Shape size/location changed"

    'Set new size
    sizeDict(shp.Name) = GetSize(shp)
  end if
End Sub
Sub Shapes_Created(shp as shape)
  sizeDict(shp.name) = GetSize(shp)
End Sub
Sub Shapes_Deleted(oldName as string)
  sizeDict.remove(shp.name)
End Sub
Sub Shapes_Renamed(shp as shape, oldName as string)
  Shapes_Created shp
  Shapes_Deleted oldName
End Sub

Private Function GetSize(shp as shape) ads string
  With shp
    GetSize = .Top & "|" & .Left & "|" & .Width & "|" & .Height
  end with
End with

Workbook Code.bas

Dim WithEvents shpEvents As stdShapeEvents

Sub latchEvents()
  Set shpEvents = New stdShapeEvents
  Call shpEvents.HookSheet(Sheet2)
End Sub

Private Sub shpEvents_Changed(shape As shape)
  Debug.Print shape.Name & " Changed"
End Sub

Private Sub shpEvents_Deselected(shape As shape)
  Debug.Print shape.Name & " Deselected"
End Sub

Private Sub shpEvents_Selected(shape As shape)
  Debug.Print shape.Name & " Selected"
End Sub

Private Sub shpEvents_Created(shape As shape)
  Debug.Print shape.Name & " Created"
End Sub

Private Sub shpEvents_Deleted(shpName As string)
  Debug.Print shpName & " Deleted"
End Sub

Private Sub shpEvents_Renamed(shape As shape, oldName as string)
  Debug.Print oldName & " renamed to " & shape.name
End Sub

Private Sub shpEvents_Selected(shape As shape)
  Debug.Print shape.Name & " Selected"
End Sub

many syntax errors, in this, for example

what the object stdShapeEvents? Also, can't importing CShapeEvents.cls as VBA Class.

Can I use your subclassing to get the shape rectangle resize event?

ofc 😊

many syntax errors, in this, for example

by many, you mean like 2? xD

stdShapeEvents

This is the class defined in CShapeEvents.cls

@sancarn , my dear friend, where are i can write to you by private message? I want to send data from excel to googlesheet (and possible receive backward). There is an implementation of one programmer, but in this example Excel calls IE, and google currently bans internet explorer. Can you help me fix the code so it calls Firefox for example?

I would suggest asking on http://reddit.com/r/vba I'd bet there is someone there who has worked with google sheets before

ok, let's go further

where i can find this method stdShapeEvents.Create()

  Sub latchEvents()
    Set shpEvents = stdShapeEvents.Create(Sheet2)
    Call shpEvents.HookSheet(Sheet2)
  End Sub

in stdShapeEvents that is not present

upd. oh, i think it must be replaced by
Set shpEvents = New stdShapeEvents

upd. it really works!
but how did you manage to find such a non-trivial solution using bars?!
it's fantastic solution without low level winapi hooks functions using.