如何使用VBA将所选PowerPoint幻灯片中的每个形状分组？

Question

我正在处理具有多种形状的景观图。我试图通过一次选择所有形状（Ctrl + A）并进行分组来在具有许多形状的幻灯片中进行跟踪。如果我通过选择PowerPoint中存在的内置分组功能手动执行此操作，则形状（红色和黄色框）不会分组，而是将所有四个框分组为一堆。

我正在尝试实现以下目标：（参考所附示例）

1. 选择所有4种形状
2. 运行宏时，应将框归为一组（即，黄色和红色形状以及绿色和蓝色形状均应配对）

以下是我尝试实现此目的的代码。但是，选择中只有前两个形状被分组，而其他两个则没有。

value

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