How to rename shapes within grouped groups in PowerPoint with VBA-CodePudding

I have a group of groups of shapes, the relevant ones of which are pairs made of a shape and a text box (the whole drawing is imported as SVG image and ungrouped to make it editable). I would like, for each of the pairs, the shapes to be renamed after what's written in the text boxes, but I cannot find a way to access such shapes. I get the error objects does not support property or method at "Target" and I have tried several ways to name it (oSh(G).GroupItems(i) among others) but non is the correct way, could someone please help me?

Sub GiveNamesToShapes()
Dim oSlide As slide
Dim oSh As Shape
Dim i As Integer
Dim Source As String
Dim Target As Shape
Dim Group As Shape
Dim G As Integer


    For Each oSh In ActivePresentation.Slides(1).Shapes
        For G = 1 To ActivePresentation.Slides(1).Shapes.Count
            If ActivePresentation.Slides(1).Shapes(G).Type = msoGroup Then
    
                For i = 1 To oSh.GroupItems.Count
    
                    If oSh.GroupItems(i).TextFrame2.HasText = True Then
    
                    Source = oSh.GroupItems(i).TextFrame2.TextRange
                        
                    ElseIf oSh.GroupItems(i).TextFrame2.HasText = False Then
                    
                        With ActivePresentation.Slides(1).Shapes.Range.GroupItems
                        Target = oSh.GroupItems(i) ''here the error
                        End With
                        
                    End If
    
                    With oSh.GroupItems(i) = Target
                          Set .Name = Source
                    End With
                Next
            End If
        Next
    Next
End Sub

CodePudding user response：

This was significantly more difficult than expected because you can not directly access subgroups of groups of shapes with VBA. This solution uses recursion and accesses the subgroups by ungrouping the "parent" group and then regrouping it.

Sub GiveNamesToShapes()
    Dim oSlide As Slide
    Set oSlide = ActivePresentation.Slides(1)
    
    Dim shp As Shape
    Dim id As Long
    For Each shp In oSlide.shapes
        If shp.Type = msoGroup Then
            NameGroup shp, id, oSlide
        End If
    Next shp
End Sub

Sub NameGroup(ByVal oShpGroup As Object, _
              ByRef id As Long, _
              ByVal sld As Slide)
    Dim groupName As String, shp As Shape, shapes As ShapeRange, text As String
    groupName = oShpGroup.name
    Set shapes = oShpGroup.Ungroup
    For Each shp In shapes
        If Not shp.Type = msoGroup Then
            If shp.TextFrame.HasText = msoTrue Then _
                text = shp.TextFrame.TextRange.text
        End If
    Next shp
    For Each shp In shapes
        If Not shp.Type = msoGroup Then
            If shp.TextFrame.HasText = msoTrue Then
                'You can name the TextBox here if desired
                'item.name =
            Else
                'The item that is grouped with the TextBox, but not the
                'TextBox itself, will be named here:
                shp.name = text
            End If
        End If
    Next shp
    Dim ids() As Long, i As Long: i = 1
    ReDim ids(1 To shapes.Count)
    For Each shp In shapes
        If shp.Type = msoGroup Then
            NameGroup shp, ids(i), sld: i = i   1
        Else
            ids(i) = shp.id: i = i   1
        End If
    Next shp
    Dim indices() As Long, j As Long
    ReDim indices(LBound(ids) To UBound(ids))
    For i = LBound(ids) To UBound(ids)
        For j = 1 To sld.shapes.Count
            If sld.shapes(j).id = ids(i) Then indices(i) = j: Exit For
        Next j
    Next i
    Set shp = sld.shapes.Range(indices).group
    id = shp.id
    'You can name the group here if desired. By default, it will get its
    'original name back
    shp.name = groupName
End Sub