如何使用 VBA 将所选 PowerPoint 幻灯片中的每个形状分组? [英] How to group each shape in a selection of a PowerPoint slide using VBA?

问题描述

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

I am working on a landscape diagram that has many shapes. I am trying to do following in a slide that has many shapes by selecting all the shapes at once (Ctrl + A) and perform grouping. If I do this manually by selecting the inbuilt group function present in PowerPoint, the shapes (red and yellow boxes) are not grouped, instead all four boxes are grouped as bunch.

我正在努力实现以下目标:(参考所附示例)

I am trying to achieve the following: (Taking reference of example attached)

1. 选择所有 4 个形状
2. 当宏运行时，盒子应该被分组(即黄色和红色形状应该配对以及绿色和蓝色形状)

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

Following is the code I tried for achieving this. But, only first two shapes in the selection were grouped where as other two are not.

   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

推荐答案

在第一次循环迭代中，当前两个形状被分组时，所有形状都被取消选择.因此，在随后的循环中，您会收到一个错误，但由于您使用 On Error Resume Next 启用了错误处理，而没有在之后禁用它，因此该错误被隐藏了.

In the first loop iteration, when the first two shapes are grouped, all of the shapes get de-selected. And so in your subsequent loop, you would have received an error, but since you enabled error handling with On Error Resume Next without disabling it afterwards, the error is hidden.

错误处理 在您启用错误处理并测试是否选择了多个形状后，您应该禁用它.如果您在某个时候需要它，可以再次启用它.

Error Handling After you've enabled error handling and tested whether more than one shape has been selected, you should disable it. Should you need it at some point, it can be enabled again.

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

数组分配将每个选定的形状分配给数组中的一个元素.

Array Assignment Assign each of the selected shapes to an element within the array.

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

分组 遍历数组，测试每对中的形状是否重叠，然后确保它们都不属于一个组.

Grouping Loop through the array, test whether the shapes within each pair overlap, and then make sure that neither are already part of a group.

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

这篇关于如何使用 VBA 将所选 PowerPoint 幻灯片中的每个形状分组?的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！