|
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 |
@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.