如何用VBA在PowerPoint中取消组合后按类型重新分组形状

在上一个问题得到优质解答后，我尝试将由多个「形状+文本框」对子组成的原始分组拆分为两个组：一个仅含形状，一个仅含文本框。
我改编了上一问题的代码，并参考类似问题创建了两个对应类别的数组，但代码无法正常运行：宏调用的函数在最后一步（执行Set GroupedShapes = oSlide.shapes.Range(ShapeArray).Group分组数组时）报错，错误代码为-2147024809 (80070057)': Shapes(unknown member): Illegal value. Bad type: expected ID array of Variants, Integers, Longs, or Strings.。我尝试使用空括号Set GroupedShapes = oSlide.shapes.Range(ShapeArray()).Group，但仍出现相同错误；使用...Range(ShapeArray(1 to .shpRng))...时，提示需用逗号分隔值。我不确定修复此问题后其余代码是否能正常运行，恳请提供建议。

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

编辑1 #

我尝试了以下代码，但出现Type mismatch（类型不匹配）错误：

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

编辑2 #

我回顾了之前的解答，发现未添加递归取消组合至无分组的循环。于是调整了数组顺序，复制了形状和文本框的变量，但仅第一组对子被取消组合。我的思路是获取形状和文本框的ID，以此分组，但添加循环后仍仅处理第一组，最后一行Set GroupedText = oSlide.shapes.Range(indicesText).Group报错，提示形状范围中至少需要两个对象。

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

当前状态 #

预期结果 #

内容的提问来源于stack exchange，提问作者Oran G. Utan