|
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 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!