使用 VBA 在 PowerPoint 中取消分組后如何按類型重新組合形狀

Question

根據對我上一個問題的出色回答，我試圖從一組原始的分組對中創建兩組，一組由形狀組成，一組由文本框組成，每組由一個形狀和一個文本框組成。 我嘗試創建兩個 arrays，每個類別一個，方法是調整上一個問題的答案中的代碼並查看我發現的類似問題，例如此處，但是我想出的方法不起作用：宏調用的 function 停在最后一步（當我嘗試對數組進行分組時，即Set GroupedShapes = oSlide.shapes.Range(ShapeArray).Group錯誤-2147024809 (80070057)': Shapes(uknown member): Illegal value. Bad type: expected ID array of Variants, Integers, Longs, or Strings. -2147024809 (80070057)': Shapes(uknown 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))...在收到提示時工作，我應該用逗號分隔值。 但是，我什至不確定如果這個問題得到解決，rest 是否真的有效。 有人可以建議嗎？

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

編輯：我剛剛嘗試了以下，但我得到Type mismatch

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

編輯2：

我回到我所指的答案並意識到我沒有將循環添加到“核心”，直到沒有組為止。 然后我更改了 arrays 的順序並將它們放在這之后，天真地認為通過將形狀和文本框的變量加倍我會得到預期的結果，但第一對形狀只會被取消分組。 我的想法是獲取形狀和文本框的 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

原樣

預期結果

Answer 1

我的一個同事總是告訴我使用 F8 來查看宏的作用，而以上所有這些都清楚地表明我沒有這樣做。 不夠。 我意識到我試圖在 function 中對項目進行分組，而實際上這應該在取消分組后發生在宏本身中。 我從這個答案中得到靈感（記住它下面的評論：形狀必須有不同的名稱）現在一切都按預期工作。

我不明白的一件事：在Debug.Print Parent.name行中，Immediate Window 表示Microsoft Excel ，但我在 PowerPoint 中運行它並且 Excel 已關閉。

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