如何使用 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