如何使用 VBA 將所選 PowerPoint 幻燈片中的每個形狀分組？

Question

我正在制作具有多種形狀的景觀圖。 我正在嘗試通過一次選擇所有形狀（Ctrl + A）並執行分組來在具有許多形狀的幻燈片中進行跟蹤。 如果我通過選擇 PowerPoint 中的內置分組功能手動執行此操作，則形狀（紅色和黃色框）不會分組，而是所有四個框都分組為一堆。

我正在嘗試實現以下目標：（參考所附示例）

1. 選擇所有 4 個形狀
2. 當宏運行時，盒子應該被分組（即黃色和紅色形狀應該配對以及綠色和藍色形狀）

以下是我為實現這一目標而嘗試的代碼。 但是，只有選擇中的前兩個形狀被分組，而其他兩個則沒有。

   Sub Grouping2()
   Dim V As Long
   Dim oSh1 As Shape
   Dim oSh2 As Shape
   Dim Shapesarray() As Shape
   Dim oGroup As Shape
   Dim oSl As Slide


  Call rename
  On Error Resume Next
  If ActiveWindow.Selection.ShapeRange.Count < 2 Then
  MsgBox "Select at least 2 shapes"
  Exit Sub
  End If
 ReDim Shapesarray(1 To ActiveWindow.Selection.ShapeRange.Count)


For V = 1 To ActiveWindow.Selection.ShapeRange.Count

     Set oSh1 = ActiveWindow.Selection.ShapeRange(V)
     Set oSh2 = ActiveWindow.Selection.ShapeRange(V + 1)

         If ShapesOverlap(oSh1, oSh2) = True Then

             Set Shapesarray(V) = oSh1
             Set Shapesarray(V + 1) = oSh2
              ' group items in array
             ActivePresentation.Slides(1).Shapes.Range(Array(oSh1.Name, oSh2.Name)).Group


               'else move to next shape in selction range and check
          End If

 V = V + 1
 Next V
End Sub


Sub rename()
Dim osld As Slide
Dim oshp As Shape
Dim L As Long
Set osld = ActiveWindow.Selection.SlideRange(1)
For Each oshp In osld.Shapes
If Not oshp.Type = msoPlaceholder Then
L = L + 1
oshp.Name = "myShape" & CStr(L)
End If
Next oshp
End Sub

Answer 1

在第一次循環迭代中，當前兩個形狀被分組時，所有形狀都被取消選擇。 因此，在隨后的循環中，您會收到一個錯誤，但是由於您使用On Error Resume Next啟用了錯誤處理，而沒有在之后禁用它，因此該錯誤被隱藏了。

錯誤處理在啟用錯誤處理並測試是否選擇了多個形狀后，您應該禁用它。 如果您在某個時候需要它，可以再次啟用它。

On Error Resume Next
If ActiveWindow.Selection.ShapeRange.Count < 2 Then
    MsgBox "Select at least 2 shapes"
    Exit Sub
End If
On Error GoTo 0

數組分配將每個選定的形狀分配給數組中的一個元素。

Dim Shapesarray() As Shape
ReDim Shapesarray(1 To ActiveWindow.Selection.ShapeRange.Count)

Dim V As Long

For V = 1 To ActiveWindow.Selection.ShapeRange.Count
    Set Shapesarray(V) = ActiveWindow.Selection.ShapeRange(V)
Next V

分組循環遍歷數組，測試每對中的形狀是否重疊，然后確保它們都不是組的一部分。

For V = LBound(Shapesarray) To UBound(Shapesarray) - 1
    If ShapesOverlap(Shapesarray(V), Shapesarray(V + 1)) Then
        If Not Shapesarray(V).Child And Not Shapesarray(V + 1).Child Then
            ActiveWindow.View.Slide.Shapes.Range(Array(Shapesarray(V).Name, Shapesarray(V + 1).Name)).Group
        End If
    End If
Next V

完整的代碼如下...

   Sub Grouping2()

    'Call rename

    On Error Resume Next
    If ActiveWindow.Selection.ShapeRange.Count < 2 Then
        MsgBox "Select at least 2 shapes"
        Exit Sub
    End If
    On Error GoTo 0

    Dim Shapesarray() As Shape
    ReDim Shapesarray(1 To ActiveWindow.Selection.ShapeRange.Count)
    Dim V As Long

    For V = 1 To ActiveWindow.Selection.ShapeRange.Count
        Set Shapesarray(V) = ActiveWindow.Selection.ShapeRange(V)
    Next V

    For V = LBound(Shapesarray) To UBound(Shapesarray) - 1
        If ShapesOverlap(Shapesarray(V), Shapesarray(V + 1)) Then
            If Not Shapesarray(V).Child And Not Shapesarray(V + 1).Child Then
                ActiveWindow.View.Slide.Shapes.Range(Array(Shapesarray(V).Name, Shapesarray(V + 1).Name)).Group
            End If
        End If
    Next V

End Sub