Search code examples
vbapowerpoint

How to regroup shapes by type after ungrouping them in PowerPoint with VBA

Following the excellent answer to my previous question, I am trying to make two groups, one made of shapes and one of textboxes, out of an original group of grouped pairs, each composed of a shape and a textbox. I tried creating two arrays, one for each category, by adapting the code from the answer to the previous question and looking at similar questions I found, like here, however what I came up is not working: the function called by the macro stops at the last step (when I try to group the array i.e. Set GroupedShapes = oSlide.shapes.Range(ShapeArray).Group) with error -2147024809 (80070057)': Shapes(uknown member): Illegal value. Bad type: expected ID array of Variants, Integers, Longs, or Strings. I tried leaving blank brackets --> Set GroupedShapes = oSlide.shapes.Range(ShapeArray()).Group as from what I understand something is missing in there, but I get the same error, nor does ...Range(ShapeArray(1 to .shpRng))... work as I receive the prompt I should separate values by a comma. However, I am not even sure that if this is fixed the rest will actually work. Could someone please advise?

Sub GiveNamesToShapes()
    Dim oSlide As slide
    Set oSlide = ActivePresentation.Slides(ActiveWindow.View.slide.SlideIndex)
    
    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

    Dim TextArray() As Variant 'these are the variables I created
    Dim ShapeArray() As Variant
    Dim GroupedShapes As Shape
    Dim GroupedText As Shape
    
    Dim i As Integer 'these are the variables I created
    Dim y As Integer
    
    Dim Shp_Cntr As Double
    Dim Shp_Mid As Double
    
    Dim ShapeLeft As Double
    Dim ShapeRight As Double
    Dim ShapeWidth As Double
    Dim ShapHeight As Double
    
    groupName = oShpGroup.name
    
    Dim oSlide As slide: Set oSlide = oShpGroup.Parent

    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 = msoFalse Then
                        
                With shp
'here is the first array i created (shapes)
                    Dim indicesShapes() As Long, z As Long: ReDim indicesShapes(LBound(ShapeArray) To UBound(ShapeArray))
                        For i = LBound(ShapeArray) To UBound(ShapeArray)
                            For z = 1 To oSlide.shapes.Count
                                Set oSlide.shapes(z) = ShapeArray(i) 'Then indices(i) = j: Exit For
                            Next z
                        Next i

'up to here
                End With
                
                ShapeLeft = shp.Left
                ShapeTop = shp.Top
                ShapeWidth = shp.Width
                ShapeHeight = shp.Height
                
                Shp_Cntr = ShapeLeft + ShapeWidth / 2
                Shp_Mid = ShapeTop + ShapeHeight / 2
                
                shp.name = txt
                
            Else
                With shp
'this is the second Array (for textboxes)
                    Dim indicesText() As Long, p As Long: ReDim indicesText(LBound(TextArray) To UBound(TextArray))
                        For y = LBound(TextArray) To UBound(TextArray)
                            For p = 1 To oSlide.shapes.Count
                                Set oSlide.shapes(p) = TextArray(y) 'Then indices(i) = j: Exit For
                            Next p
                        Next y

'up to here

                .TextFrame.WordWrap = False
                .TextFrame.AutoSize = ppAutoSizeShapeToFitText
                .TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignCenter
                .TextFrame.VerticalAnchor = msoAnchorMiddle
                
                .Left = Shp_Cntr - .Width / 2
                .Top = Shp_Mid - Height / 2
                    
                End With
            End If
        End If
    Next shp
    
'here is where I try to group the items in the arrays and I get the error
    Set GroupedShapes = oSlide.shapes.Range(ShapeArray).Group
    Set GroupedText = oSlide.shapes.Range(TextArray).Group
    
End Function

EDIT: I have just tried the below, but I get Type mismatch

    Set GroupedShapes = oSlide.shapes.Range(indicesShapes(ShapeArray)).Group
    Set GroupedText = oSlide.shapes.Range(indicesText(TextArray)).Group

EDIT2:

I went back to the answer I am referring to and realized I did not add the loop to ungroup to the "core", that is till there are no groups left. I then changed the order of the arrays and placed them after this, naively thinking that by doubling the variables for shapes and textboxes I would get the expected result, but the first pair of shapes only gets ungrouped. The idea I had was to get the ids of shapes and textboxes, so they would be grouped accordingly, however the below stops at the first pair despite the loop I have added until there are groups so the last line Set GroupedText = oSlide.shapes.Range(indicesText).Group gives error saying that in the shape range there must be at least two objects.

Sub GiveNamesToShapes()
    Dim oSlide As slide
    Set oSlide = ActivePresentation.Slides(ActiveWindow.View.slide.SlideIndex)
    
    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
    Dim TextArray() As Variant
    Dim ShapeArray() As Variant
    Dim GroupedShapes As Shape
    Dim GroupedText As Shape
   
    groupName = oShpGroup.name
    
    Dim oSlide As slide: Set oSlide = oShpGroup.Parent

    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 = msoFalse Then

                
                shp.name = txt
                

            End If
        End If
    Next shp
    
    
    Dim Shapeids() As Long, i As Long: ReDim Shapeids(1 To shpRng.Count): i = 1
    Dim Textids() As Long, y As Long: ReDim Textids(1 To shpRng.Count): y = 1
    For Each shp In shpRng
            Do While shp.Type = msoGroup  'I added this loop to ungroup recursively, but it does not go through all groups, it works only on the first one               
                            Call NameGroup(shp)
            Loop
            
            If shp.TextFrame.HasText = msoTrue Then
        
                    Textids(y) = shp.id: y = y + 1
            
            ElseIf shp.TextFrame.HasText = msoFalse Then
            
                    Shapeids(i) = shp.id: i = i + 1
            End If
    Next shp
    
    
    Dim Textindices() As Long, p As Long: ReDim Textindices(LBound(Textids) To UBound(Textids))
        For y = LBound(Textids) To UBound(Textids)
            For p = 1 To oSlide.shapes.Count
                If oSlide.shapes(p).id = Textids(y) Then Textindices(y) = p: Exit For
            Next p
        Next y
        
    Dim Shapeindices() As Long, z As Long: ReDim Shapeindices(LBound(Shapeids) To UBound(Shapeids))
        For i = LBound(Shapeids) To UBound(Shapeids)
            For z = 1 To oSlide.shapes.Count
                If oSlide.shapes(z).id = Shapeids(i) Then Shapeindices(i) = z: Exit For
            Next z
        Next i
    
    
    Set GroupedShapes = oSlide.shapes.Range(Shapeindices).Group 'here it stops and it says there must be two objects to make a group, only the first pair is ungroupd (the primary, big group containing all is gone) while all oteher pairs are still grouped

    Set GroupedText = oSlide.shapes.Range(Textindices).Group 
    
End Function

As is

enter image description here

Expected Result

enter image description here

Solution

  • A colleague of mine always tells me to use F8 to se what macros do, and all the above shows clearly I did not do it. Not enough. I realized I was trying to group the items while in the function, when in fact this should have occurred in the macro itself, after the ungrouping. I took inspiration from this answer (keeping in mind the comment right below it: shapes must have different names) and now everything is working as expected.

    One thing I do not understand: at the line Debug.Print Parent.name the Immediate Window says Microsoft Excel, but I am running this in PowerPoint and Excel is closed.

    Sub GiveNamesToShapes_Center_AndThenRegroup()
    Dim oSlide As slide
    Set oSlide = ActivePresentation.Slides(ActiveWindow.View.slide.SlideIndex)
    
    Dim x As Long
    Dim sTemp As String
    
    Dim ShapeList() As String
    Dim ShapeCount As Long
    
    Dim TextList() As String
    Dim TextCount As Long
    
    Dim shp As Shape
    For Each shp In oSlide.shapes
        If shp.Type = msoGroup Then
            NameGroup shp
            
        Else
        
        For x = 1 To oSlide.shapes.Count

            If oSlide.shapes(x).TextFrame.HasText = msoFalse Then
                ShapeCount = ShapeCount + 1
                
                
            Else
                TextCount = TextCount + 1
            End If
        Next x 'EDIT 2022/11/24 --> I added 'x' as with crowded groups coming from SVG files the part above ''If shp.Type = msoGroup Then'' was being skipped


        ReDim ShapeList(1 To ShapeCount)
        ReDim TextList(1 To TextCount)

        ShapeCount = 0
        TextCount = 0

        For x = 1 To oSlide.shapes.Count

            If oSlide.shapes(x).TextFrame.HasText = msoFalse Then
                ShapeCount = ShapeCount + 1
                ShapeList(ShapeCount) = oSlide.shapes(x).name
                
            Else
                TextCount = TextCount + 1
                TextList(TextCount) = oSlide.shapes(x).name
            End If
        Next x 'EDIT 2022/11/24 --> I added 'x' as with crowded groups coming from SVG files the part above ''If shp.Type = msoGroup Then'' was being skipped


        If UBound(ShapeList) > 0 Then
            oSlide.shapes.Range(ShapeList).Group
        End If
        If UBound(TextList) > 0 Then
            oSlide.shapes.Range(TextList).Group
        End If
            

        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
    

    
    Dim Shp_Cntr As Double
    Dim Shp_Mid As Double
    
    Dim ShapeLeft As Double
    Dim ShapeTop As Double
    Dim ShapeWidth As Double
    Dim ShapeHeight As Double
    
    
    groupName = oShpGroup.name
    Debug.Print oShpGroup.name
    Dim oSlide As slide: Set oSlide = oShpGroup.Parent
    Debug.Print Parent.name

    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 = msoFalse Then
            
                shp.name = txt
            
                ShapeLeft = shp.Left

                ShapeTop = shp.Top

                ShapeWidth = shp.Width

                ShapeHeight = shp.Height

                
                Shp_Cntr = ShapeLeft + ShapeWidth / 2
                Shp_Mid = ShapeTop + ShapeHeight / 2

            Else

                With shp
                                shp.name = "Textbox " & txt
                    .TextFrame.WordWrap = False
                    .TextFrame.AutoSize = ppAutoSizeShapeToFitText
                    .TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignCenter
                    .TextFrame.VerticalAnchor = msoAnchorMiddle
                    
                    .Left = Shp_Cntr - (.Width / 2)
                    .Top = Shp_Mid - (.Height / 2)
                End With


            End If
        End If
    Next shp
    

    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

             NameGroup shp

        End If
    Next shp

End Function