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

@sancarn, many thanks for your kind support, Sir.
I still have a long way to go open source on github.
I am still learning. No where near being a programmer. I don't think I'll ever be able to make money out of coding.
No real training apart from a 1 on 1 training on Turbo Pascal 7.0 about 24 years ago, circa 1996.
Even VBA, I taught myself about 5 years ago after having to work with MS Excel.
I am writing code because I love it.
Even this project was started then set aside and then restarted and then put aside then picked up like 3-5 times already.

But if and when this project is ready, you will be the first to know.
With your kind permission, I can show off a screenshot...I don't know if it's appropriate to upload a photo here, if not, please let me know and I will remove it.

The shapes were not created by me. They were taken from a similar map tool from Myanmar Information Management Unit, the MIMU.
The CShape Class will be used for identifying a selected shape, a feature which will be implemented, hopefully, next week.
My project was intended to help people without GIS knowledge to be able to use some administrative level geographic data visualization.

@NLYinMaung Very cool stuff! I've been wanting to implement a GIS engine into Excel for a while by now. Currently I've only got as far a parsing MapInfo files, but as of yet not go around to parsing ArcGIS shape files. I love GIS, used to do it a few years ago for a living. It always made me sad Excel didn't have similar functionality. Creating a GIS layer as shapes is pretty amazing. How good is the performance with all those shapes?

I am still learning. No where near being a programmer. I don't think I'll ever be able to make money out of coding. No real training apart from a 1 on 1 training on Turbo Pascal 7.0 about 24 years ago, circa 1996. Even VBA, I taught myself about 5 years ago after having to work with MS Excel.

This is a similar story with me. I only started learning about 6 years ago and I too mainly do this out of a love of the language. VBA isn't the best language but everything is possible in VBA, which is not as easily said for more modern languages. From what I've seen, you've clearly got the intuition to be a good programmer 😃 Keep it up!

I don't know if it's appropriate to upload a photo here, if not, please let me know and I will remove it.

As far as I am concerned it is related to the class, so by all means keep it here 👍

@sancarn, I appreciate your kind support.
I agree with you in that having shapes in MS Excel is like a gift from god, to me.
It is light years away from real GIS applications but still, even if people don't find it useful, I am really happy working on this.
I went on a postgraduate diploma in GIS for a while but since it was just a diploma course, they didn't really give us much.

Concerning the performance with 330 shapes on my 32Bit MS Excel 2010 on my Win10, ASUS GW501J with 12GB RAM, i7, it's more than fine.
But one listview with about 770 listitems is not very smooth scrolling but flashing here and there but I guess that it's with the nature of listviews.
Apart from that, the remainder of listviews and Treeviews with 330ish items are absolutely fine.
The whole workbook is functioning pretty normal.
But I am not sure about the conditions on an i3 with 4GB RAM, though they are rare these days, they are what we have most in my country.

However, I don't think there's anything slowing the code down because, most of the time, there will be only a few userforms opened with some 330ish items inside and I don't expect much calculations or processor heavy stuff going on, at least that was what I planned so far.
But I am worried about several global dictionaries I have to employ.
I think that I can streamline the code later, but for now, I am just trying to realize my vision first. I don't know if that's the right approach.

My current goal is just to let the user select some townships and then put them down on the sheet in a dataframe.
Then fill up some numbers beside the township names and then reupload into the listview and do the choropleth thing to the map shapes.
From there, just some features for beautification of the map left.
The rest of the features will be for letting others use this .xlsm as a reference to quickly learn/show where a township is or how the administrative hierarchy was ordered.
Beyond that, I just want to show people what I/they can do with MS Excel with the help of VBA.

I think there's a builtin map feature starting from MS Excel 2013. I am not sure. And Tableau has a great map tool too.
But I think working with these shapes like I am doing now, gives me more control. May be I am wrong.

Recently, I dipped my toes in Python. It's fun. It's great. It can do very cool stuff like list-comprehension which is one of my most favorite features it has to offer.
But then again, here I am, coding in my venerable VBA.
I even tried PySpark. Loved it. But these are two very different tools, Python and VBA.
Python is great but to me, VBA is and will always be my go-to tool even if a great many number of people look down on it, as if programming in it would belittle their names.

The first person/place where I first found out how to use freeform shapes as maps in MS Excel is from ClearlyAndSimply website around 2011 or 2012. You can find it here:
[]((https://www.clearlyandsimply.com/clearly_and_simply/2012/12/create-excel-choropleth-maps-from-shape-files.html)
In fact, reading about it caused me to start learning VBA.

Sorry that I rant on and on about myself.
You did make the CShape class. I am sure you can go further than me and develop a better GIS solution any given day.
Anyway, I am so glad that we are alike in our love for VBA.

Thank you again for everything. And have a nice week end. Very nice talking to someone who shares the same interest.

Beyond that, I just want to show people what I/they can do with MS Excel with the help of VBA.
On that note I suggest you post it to reddit when it's done :) Make sure to flair the post as "Show and Tell" 🙂 That's where I post a lot of my libraries.

But I think working with these shapes like I am doing now, gives me more control. May be I am wrong.

I think you are correct there!

Python is great but to me, VBA is and will always be my go-to tool even if a great many number of people look down on it, as if programming in it would belittle their names.

If Python (or any other modern server side programming language) was available at work, I think I'd be using that also. Those who frown/wince at VBA are those who have the freedom to choose to use whatever they want. Many business staff don't have that luxury. Anyway, I think the main reason people dislike VBA is typically code is unstructured, unindented and most often recorded. In fairness, I dislike that kind of code too. When you have structured indented VBA code, it becomes as readable and maintainable as C#, JavaScript, Python etc.

P.S. If you're interested in a modern-style VBA library check out stdVBA

Looks like we're both ranters! Chou!

@sancarn, I agree with everything in your comment. Will probably do a Reddit thingy too.
I take myself as an introvert but who knows

I just checked out your stdVBA...
I always believed, the late but great, Mr. Chip Pearson, to be the VBA God. I worshiped him.

But here you are, I think you're the VBA-Supreme-Being.
May be one of the new Gods from VBA Apokolips. LOL.

I can't even fathom how far you took VBA into the future...
Even if you are just sharing your collections, you must have ventured to the far corners of VBA where no one has gone before.

I am not going to pretend that I understand the many things that your stdVBA can do.
It would take me a very long time, even to begin to understand what it can do, not to mention understanding and employing it.
And here I am, still struggling to understand your CShape Class or even that Short Example on stdVBA repo.
I suspect that it's drawing a map shape. I just went bananas reading through the syntax.
But I will surely explore the stdVBA further.

I know one thing only, that it really is amazing.
I think that you connected VBA with every other modern tech, like Frankenstein connected to the Thunder Clouds via lightning and copper wires!
And then Boom!
You just revived it and gave it wings, claws and fangs, complete with acidic blood and poisonous spit!

Anyway, I keep getting a feeling like I have hijacked your thread. So, may be I better stop ranting here.
Really enjoyed your kindness.
Thank you for introducing me to the future!!!
You Rock, Man!

Hey complete noob, here. How exactly would i get this to work? I have added a picture, its name box read "picture 2".

For now i've copied CShapeEvents.cls into a new class module labeled class1.

Then I added within my sheet the following code.

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

I then went to delete the picture, but nothing happened.

How could I go about executing any command upon the deletion of "picture 2"

Hey complete noob, here. How exactly would i get this to work? I have added a picture, its name box read "picture 2".

I'd strongly advise reading all comments in the code, as a usage example is in there. Also reading some of the comments here as I've gone over it before.

Hi @sancarn , i'm not good english, i'm sorry if you don't understand what i'm saying.
i'm looking for an event for shape, but when i copy the code to the file it doesn't work, probably because i don't know how to use it yet. Can you give me a sample excel file?
I have a hard time asking questions, because I'm using google translate

Hi @sancarn !
Can I use your subclassing to get the shape rectangle resize event?
Now I can recalculate the rectangle dimension only after the move focus from it and event Worksheet_SelectionChange() fired.
I mean that shape rectangle

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.