Grouping an Array of Shapes - excel

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.

Answer 1

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