使用 VBA 在 Powerpoint 中的多行中以相同高度对形状进行分组

Question

我想在 PPT 中创建一个 VBA 宏，以便使用 VBA 在 Powerpoint 中跨多行以相同高度对形状进行分组。理想情况下，我的第一步应该是这样的图像： Group Textboxes row wise

在垂直和水平方向均匀分布的许多行和列中有一个文本框矩阵。我想完全选择所有形状并运行一个宏来将文本框按行分组为多行。下面的代码是复制的，还不是最终的，感谢任何帮助，sn-ps，非常感谢。

Sub GroupSameHeightObjects()

  ' Dimension the variables.
  Dim shapeObject As shape
  Dim lSlideNumber As Long
  Dim strPrompt, strTitle As String
  Dim ShapeList() As String
  Dim count As Long

  ' Initialize the counter.
  count = 0

  ' Make sure PowerPoint is in slide view.
  If ActiveWindow.ViewType <> ppViewSlide Then

     ' Set up the error message.
     strPrompt = "You must be in slide view to run this macro." _
        & " Change to slide view and run the macro again."
     strTitle = "Not In Slide View"

     ' Display the error message.
     MsgBox strPrompt, vbExclamation, strTitle

     ' Stop the macro.
     End

  End If

  ' Get the current slide number.
  lSlideNumber = ActiveWindow.Selection.SlideRange.SlideNumber

  ' Loop through the shapes on the slide.
  For Each shapeObject In _
     ActivePresentation.Slides(lSlideNumber).Shapes

     ' See whether shape is a placeholder.
     If shapeObject.Type <> msoPlaceholder Then

        ' Increment count if the shape is not a placeholder.
        count = count + 1

        ' Get the name of the shape and store it in the ShapeList
        ' array.
        ReDim Preserve ShapeList(1 To count)
        ShapeList(count) = shapeObject.Name

     End If

  Next shapeObject

  ' If more than 1 object (excluding a placeholder object) is found,
  ' group the objects.
  If count > 1 Then
     With ActivePresentation.Slides(lSlideNumber).Shapes

        ' Group the shapes together.
        .Range(ShapeList()).Group.Select
     End With
  Else

     Select Case count

        ' One shape found.
        Case 1

           ' Set up the message.
           strPrompt = "Only one shape found." _
              & " You need at least two shapes to group."
           strTitle = "One Shape Available"

        ' Zero shapes found.
        Case 0

           ' Set up the message.
           strPrompt = "No shapes found. You need to have at " _
              & "least two shapes, excluding placeholders."
           strTitle = "No Shapes Available"

        ' An error occurred.
        Case Else

           ' Set up the message.
           strPrompt = "The macro found an error it could not correct."
           strTitle = "Error"

     End Select

     ' Display the message.
     MsgBox strPrompt, vbExclamation, strTitle

  End If

End Sub

Answer 1

有几件事可能无法完全满足您的需求，但可以为您省去一些麻烦：

   Sub GroupSameHeightObjects()

  ' Dimension the variables.
  Dim shapeObject As shape
  Dim lSlideNumber As Long

  ' This will dim strPrompt as a variant
  ' Dim strPrompt, strTitle As String
  Dim strPrompt as string, strTitle as string

  Dim ShapeList() As String
  Dim count As Long

  ' Initialize the counter.
  count = 0

  ' Make sure PowerPoint is in slide view.
  If ActiveWindow.ViewType <> ppViewSlide Then

     ' Set up the error message.
     strPrompt = "You must be in slide view to run this macro." _
        & " Change to slide view and run the macro again."
     strTitle = "Not In Slide View"

     ' Display the error message.
     MsgBox strPrompt, vbExclamation, strTitle

     ' Stop the macro.
     ' See previous comment
     'End
     Exit Sub

  End If

  ' Get the current slide number.
  ' Nope, you want the SlideIndex; SlideNumber gives you the number that'll
  ' appear when you use PPT's slide numbering features; if the user sets the 
  ' starting number to something other than 1, your code will break
  'lSlideNumber = ActiveWindow.Selection.SlideRange.SlideNumber
   lSlideNumber = ActiveWindow.Selection.SlideRange.SlideIndex

  ' Loop through the shapes on the slide.
  For Each shapeObject In _
     ActivePresentation.Slides(lSlideNumber).Shapes

     ' See whether shape is a placeholder.
     If shapeObject.Type <> msoPlaceholder Then

        ' Increment count if the shape is not a placeholder.
        count = count + 1

        ' Get the name of the shape and store it in the ShapeList
        ' array.
        ' I've learned not to trust shape names in PPT
        ' I'd dim ShapeList as an array of shapes and then
        ' Set ShapeList(count) = shapeObject
        ReDim Preserve ShapeList(1 To count)
        ShapeList(count) = shapeObject.Name

     End If

  Next shapeObject

' You could include this next bit in the following Case selector,
' Case > 1 ... etc.    
      ' If more than 1 object (excluding a placeholder object) is found,
      ' group the objects.
      If count > 1 Then
         With ActivePresentation.Slides(lSlideNumber).Shapes

        ' Group the shapes together.
        .Range(ShapeList()).Group.Select
     End With
  Else

     Select Case count

        ' One shape found.
        Case 1

           ' Set up the message.
           strPrompt = "Only one shape found." _
              & " You need at least two shapes to group."
           strTitle = "One Shape Available"

        ' Zero shapes found.
        Case 0

           ' Set up the message.
           strPrompt = "No shapes found. You need to have at " _
              & "least two shapes, excluding placeholders."
           strTitle = "No Shapes Available"

        ' An error occurred.
        Case Else

           ' Set up the message.
           strPrompt = "The macro found an error it could not correct."
           strTitle = "Error"

     End Select

     ' Display the message.
     MsgBox strPrompt, vbExclamation, strTitle

  End If

End Sub

Answer 2

我现在没有时间编写/测试任何代码，但如果我必须这样做，我会从另一个项目中得到的类似 sn-p 的东西开始：

Sub GroupCertainShapes()

    Dim x As Long
    Dim sTemp As String
    Dim aShapeList() As String
    Dim lShapeCount As Long

    With ActivePresentation.Slides(1)
        ' iterate through all shapes on the slide
        ' to get a count of shapes that meet our condition
        For x = 1 To .Shapes.Count
            ' Does the shape meet our condition? count it.
            If .Shapes(x).Type = msoAutoShape Then
                lShapeCount = lShapeCount + 1
            End If
        Next

        ' now we know how many elements to include in our array,
        ' so redim it:
        ReDim aShapeList(1 To lShapeCount)

        ' Reset the shape counter
        lShapeCount = 0

        ' Now add the shapes that meet our condition
        ' to the array:
        For x = 1 To .Shapes.Count
            ' apply some criterion for including the shape or not
            If .Shapes(x).Type = msoAutoShape Then
                lShapeCount = lShapeCount + 1
                aShapeList(lShapeCount) = .Shapes(x).Name
            End If
        Next

        ' and finally form a group from the shapes in the array:
        If UBound(aShapeList) > 0 Then
            .Shapes.Range(aShapeList).Group
        End If

    End With
End Sub