[英]Group shapes in same height across multiple rows in Powerpoint using VBA
我想在PPT中創建VBA宏,以使用VBA在Powerpoint中的多行中將相同高度的形狀分組。 我的初始步驟理想情況下將類似於此圖像:按行分組文本框
在許多行和列中有一個垂直和水平均勻分布的文本框矩陣。 我想全部選擇所有形狀,然后運行宏以將文本框按行分組為多行。 下面的代碼已復制,但尚未最終確定,感謝任何幫助,此段代碼非常感謝。
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
有幾件事可能無法完全滿足您的需求,但可以為您省去一些麻煩:
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
我現在沒有時間編寫/測試任何代碼,但是如果必須這樣做,我將從另一個項目中的類似代碼片段開始:
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
聲明:本站的技術帖子網頁,遵循CC BY-SA 4.0協議,如果您需要轉載,請注明本站網址或者原文地址。任何問題請咨詢:yoyou2525@163.com.