Grouping an Array of Shapes

Question

When an array of Shapes is given to a subroutine By Reference, how can these Shapes be grouped, WITHOUT referring to them by their .name strings ?

The code below does not work:

Sub GroupShapes(ByRef ShapeArray() As Shape)
    Dim i As Long
    Dim IDs() As Variant
    
    ReDim IDs(LBound(ShapeArray) To UBound(ShapeArray))
    For i = LBound(ShapeArray) To UBound(ShapeArray)
        IDs(i) = ShapeArray(i).ID  'If .ID is changed into .Name then the objects become grouped Later, but they are being referred to by their name strings
    Next i
    
    ActiveSheet.Shapes.Range(IDs).Group
End Sub

I can make the code above work, just by changing .ID to .Name, but that is referring to the shapes by their .name strings which is exactly what I am trying to avoid.

user_2970789 · Answer

As has been noted, you can create a ShapeRange by index. The difficulty is in finding the index of your shape, which isn't the same as the ID property. Additionally, your shape may already be grouped, so it won't necessarily exist at Worksheet.Shapes level

It's possible to have nested shape groups, but I believe these have to be nested from bottom-level up. In other words, I think if you try to sub-group and already grouped shape, an error will be thrown.

I may be missing something obvious, but that suggests we can group the array by finding the Worksheet.Shapes level index of a shape that either is or contains our target shape. And the index could be found by iterating those top-level shapes until the unique ID property matches. It would then be possible to create a ShapeRange on the resulting indexes.

I wonder if something like this would work:

Private Function GroupShapes(ByRef shapeArray() As Shape) As Shape
    Dim i As Long, n As Long
    Dim ws As Worksheet
    Dim sh As Shape
    Dim obj As Object
    Dim idList As Collection
    Dim id As Variant
    Dim idArray() As Long
    
    'Create the list of ids for sheet level shapes.
    Set idList = New Collection
    For i = LBound(shapeArray) To UBound(shapeArray)
        Set sh = shapeArray(i)
        Do While sh.Child
            Set sh = sh.ParentGroup
        Loop
        On Error Resume Next
        idList.Add sh.id, CStr(sh.id)
        On Error GoTo 0
    Next
    If idList.Count <= 1 Then Exit Function
    
    'Define the sheet parent.
    Set obj = shapeArray(LBound(shapeArray)).Parent
    Do Until TypeOf obj Is Worksheet
        Set obj = obj.Parent
    Loop
    Set ws = obj
    
    'Find the indexes of the shape ids.
    ReDim idArray(idList.Count - 1)
    n = 0
    For Each id In idList
        i = 1
        For Each sh In ws.Shapes
            If id = sh.id Then
                idArray(n) = i
                Exit For
            End If
            i = i + 1
        Next
        n = n + 1
    Next
    
    'Group by index.        
    Set GroupShapes = ws.Shapes.Range(idArray).Group
    
End Function

The following test seemed to work for me:

Public Sub RunMe()
    Dim shapeArray(0 To 3) As Shape
    Dim g As Shape
    
    'Create a sample array.
    'Note some of these shapes are already grouped so
    'wouldnt appear at Sheet.Shapes level.
    Set shapeArray(0) = Sheet1.Shapes("Rectangle 1")
    Set shapeArray(1) = Sheet1.Shapes("Isosceles Triangle 2")
    Set shapeArray(2) = Sheet1.Shapes("Arrow: Right 4")
    Set shapeArray(3) = Sheet1.Shapes("Oval 7")
    
    'Group the array.
    Set g = GroupShapes(shapeArray)

End Sub

Grouping an Array of Shapes

1 Answers