CODEWITHSUNDEEP
vbapowerpoint
Oran G. Utan
Oran G. Utan

Reputation: 466

How to rename shapes within grouped groups in PowerPoint with VBA

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? enter image description here

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

Upvotes: 1

Views: 595

Answers (1)

GWD
GWD

Reputation: 3978

This is 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
    For Each shp In oSlide.Shapes
        If shp.Type = msoGroup Then
            NameGroup shp
        End If
    Next shp
End Sub

Function NameGroup(ByVal oShpGroup As Object) As Long
    Dim groupName As String, shp As Shape, shpRng As ShapeRange, txt As String
    groupName = oShpGroup.Name
    Dim oSlide As Slide: Set oSlide = oShpGroup.Parent
    'Ungroup the group and look at each shape inside the group
    Set shpRng = oShpGroup.Ungroup
    For Each shp In shpRng
        If Not shp.Type = msoGroup Then
            If shp.TextFrame.HasText = msoTrue Then _
                txt = shp.TextFrame.TextRange.Text
        End If
    Next shp
    For Each shp In shpRng
        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,
                'except for the TextBox itself, will be named here:
                shp.Name = txt
            End If
        End If
    Next shp
    
    'We need to get the shape ids to group the shpRng again
    Dim ids() As Long, i As Long: ReDim ids(1 To shpRng.Count): i = 1
    For Each shp In shpRng
        If shp.Type = msoGroup Then
            'For shapes that are groups themselves, call the funct. recursively.
            'Because NameGroup dis- and then reassembles the group, shpRng.Group
            'won't work anymore after this. That's why we need to get the ids.
            'NameGroup returns the id of the reassembled group.
            ids(i) = NameGroup(shp): i = i + 1
        Else
            ids(i) = shp.id: i = i + 1
        End If
    Next shp
    
    'Get the indices of the shapes with the ids in the 'ids' array
    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 oSlide.Shapes.Count
            If oSlide.Shapes(j).id = ids(i) Then indices(i) = j: Exit For
        Next j
    Next i
    Set shp = oSlide.Shapes.Range(indices).Group
    'You can name the group here if desired. By default, it will get its
    'original name back
    shp.Name = groupName
    NameGroup = shp.id 'Return the id of the reassembled group
End Function

Upvotes: 2

Related Questions