在活动演示文稿中获取*所有*形状（包括嵌套组）
Get *all* shapes (including nested groups) in active presentation
我的问题来自需要将所有文本字体更改为特定字体 A。我知道 PowerPoint 中有一个 "Change font..." 选项，但它迫使我选择 "from font" 和一个"to font"。在我的例子中，有几种不同的字体应该更改为字体 "X"。因此我写了下面的 VBA 宏。
Private Sub Set_Font_Of_All_TextFrames(oShp As Shape, font As String)
' Go through all shapes on all slides. This is a recurisve function. First call needs to pass "Nothing" to oShp.
' Any font in every textframe that is not "font" will be set to "font".
' The recursion is necessary in order to go through groups.
' BUG/TODO: Text in Master is not included so far!
Dim sld As Slide
Dim shp As Shape
Dim i As Integer
If oShp Is Nothing Then ' first subroutine call
For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
If shp.Type = msoGroup Then
Set_Font_Of_All_TextFrames shp, font ' recursive call in case of group
Else
Set_Font shp, font ' else change font
End If
Next shp
Next sld
' in case of recursive calls:
ElseIf oShp.Type = msoGroup Then
For i = 1 To oShp.GroupItems.Count()
Set shp = oShp.GroupItems.Item(i)
Set_Font_Of_All_TextFrames shp, font ' another recursive call in case of group; will repeat this branch in case of subgroup
Next
Else
Set shp = oShp
Set_Font shp, font ' else change font
End If
End Sub
'Set_Font(shp as Shape, font as String)'子程序只是为了避免冗余。它只是检查给定的 shp 是否包含 font 以外的任何其他字体的文本并更改它。在某个地方， Set_Font_Of_All_TextFrames Nothing "X" 被调用。它按预期工作，但出现以下问题：
1) 除了更改字体之外，我如何才能使此功能可用于其他操作？我真的必须复制粘贴所有这些吗？
2) 我能否像在我的函数中那样使用一个函数来遍历所有形状和组，而不是调用 set_font 子例程，而是填充一个包含对它能找到的所有形状的引用的列表？我可以将此列表传递给例如set_font 子程序（以及任何其他应该对所有形状执行操作的子程序）？
3) 为什么母版上的形状被排除在我的功能之外？
感谢评论，我发现这或多或少是要走的路。我 post 这里我 "ulitity function" 生成所有形状的集合（包括任意嵌套子组中的所有形状），可以在任何其他函数或子例程中使用和迭代。
贯穿当前演示文稿中所有幻灯片的简单版本（它还清楚地显示了该功能的运作方式）：
Function Get_All_Shapes(oShp As Shape, oColl As Collection)
' Go through all shapes on all slides. This is a recursive function. First call needs to pass "Nothing" to oShp and oColl.
' The collection oColl will be populated with all shapes (including all shapes in all groups) in the presentation.
' The return parameter will be the gradually populated collection.
' The recursion is necessary in order to go through groups.
Dim sld As Slide
Dim shp As Shape
Dim i As Integer
If oShp Is Nothing And oColl Is Nothing Then ' first function call
Set oColl = New Collection
For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
If shp.Type = msoGroup Then
Set oColl = Get_All_Shapes(shp, oColl) ' recursive call in case of group
Else
oColl.Add shp ' else add shape to collection
End If
Next shp
Next sld
' in case of recursive calls:
ElseIf oShp.Type = msoGroup Then
For i = 1 To oShp.GroupItems.Count()
Set shp = oShp.GroupItems.Item(i)
Set oColl = Get_All_Shapes(shp, oColl) ' another recursive call in case of group; will repeat this branch in case of subgroup
Next
Else
oColl.Add oShp ' else add shape to collection
End If
Set Get_All_Shapes = oColl ' set populated collection as function return parameter
End Function
这是一个更精致的版本，您可以选择是否仅使用选定的形状（和嵌套的子组）填充集合，以及是否应将带有自定义布局的母版幻灯片包含在集合中：
Function Get_All_Shapes_WIP(oShp As Shape, oColl As Collection, Optional onlySelected As Boolean = False, Optional includeMaster As Boolean = False)
' Go through all shapes on all slides. This is a recursive function. First call needs to pass "Nothing" to oShp and oColl.
' The collection oColl will be populated with all shapes (including all shapes in all groups) in the presentation.
' The return parameter will be the gradually populated collection.
' The recursion is necessary in order to go through groups.
' If onlySelected is True, only the selected shapes will be added to the collection.
' If includeMaster is True, shapes on the master slide and all custom layouts will be added to the collection. This behavior is not affected by the value of onlySelected.
Dim sld As Slide
Dim shp As Shape
Dim i As Integer
' first function call (main loops)
If oShp Is Nothing And oColl Is Nothing Then
Set oColl = New Collection
' presentation loops
If onlySelected = False Then ' all shapes on all slides
For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
If shp.Type = msoGroup Then
Set oColl = Get_All_Shapes_WIP(shp, oColl, onlySelected, includeMaster) ' recursive call in case of group
Else
oColl.Add shp ' else add shape to collection
End If
Next shp
Next sld
Else ' onlySelected = True
For Each shp In ActiveWindow.selection.ShapeRange
If shp.Type = msoGroup Then
Set oColl = Get_All_Shapes_WIP(shp, oColl, onlySelected, includeMaster) ' recursive call in case of group
Else
oColl.Add shp ' else add shape to collection
End If
Next shp
End If
' master loops
If includeMaster = True Then ' add also slide master shapes to the collection
' master shapes
For Each shp In ActivePresentation.SlideMaster.Shapes
If shp.Type = msoGroup Then
Set oColl = Get_All_Shapes_WIP(shp, oColl, onlySelected, includeMaster) ' recursive call in case of group
Else
oColl.Add shp ' else add shape to collection
End If
Next shp
' custom layouts shapes
For i = 1 To ActivePresentation.SlideMaster.CustomLayouts.Count()
For Each shp In ActivePresentation.SlideMaster.CustomLayouts.Item(i).Shapes
If shp.Type = msoGroup Then
Set oColl = Get_All_Shapes_WIP(shp, oColl, onlySelected, includeMaster) ' recursive call in case of group
Else
oColl.Add shp ' else add shape to collection
End If
Next shp
Next
End If
' recursive calls:
ElseIf oShp.Type = msoGroup Then
For i = 1 To oShp.GroupItems.Count()
Set shp = oShp.GroupItems.Item(i)
Set oColl = Get_All_Shapes_WIP(shp, oColl, onlySelected, includeMaster) ' another recursive call in case of group; will repeat this branch in case of subgroup
Next
Else
oColl.Add oShp ' else add shape to collection
End If
Set Get_All_Shapes_WIP = oColl ' set (partially) populated collection as function return parameter in every call
End Function
用法示例：
Sub Set_All_Fonts_To_Calibri()
' Sets the font of all text in all shapes in the presentation to "Calibri".
Dim coll As Collection: Set coll = Get_All_Shapes_WIP(Nothing, Nothing, onlySelected:=False, includeMaster:=True)
Dim shp As Shape
For Each shp In coll
Set_Font shp, "Calibri"
Next shp
End Sub
我的问题来自需要将所有文本字体更改为特定字体 A。我知道 PowerPoint 中有一个 "Change font..." 选项，但它迫使我选择 "from font" 和一个"to font"。在我的例子中，有几种不同的字体应该更改为字体 "X"。因此我写了下面的 VBA 宏。
Private Sub Set_Font_Of_All_TextFrames(oShp As Shape, font As String)
' Go through all shapes on all slides. This is a recurisve function. First call needs to pass "Nothing" to oShp.
' Any font in every textframe that is not "font" will be set to "font".
' The recursion is necessary in order to go through groups.
' BUG/TODO: Text in Master is not included so far!
Dim sld As Slide
Dim shp As Shape
Dim i As Integer
If oShp Is Nothing Then ' first subroutine call
For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
If shp.Type = msoGroup Then
Set_Font_Of_All_TextFrames shp, font ' recursive call in case of group
Else
Set_Font shp, font ' else change font
End If
Next shp
Next sld
' in case of recursive calls:
ElseIf oShp.Type = msoGroup Then
For i = 1 To oShp.GroupItems.Count()
Set shp = oShp.GroupItems.Item(i)
Set_Font_Of_All_TextFrames shp, font ' another recursive call in case of group; will repeat this branch in case of subgroup
Next
Else
Set shp = oShp
Set_Font shp, font ' else change font
End If
End Sub
'Set_Font(shp as Shape, font as String)'子程序只是为了避免冗余。它只是检查给定的 shp 是否包含 font 以外的任何其他字体的文本并更改它。在某个地方， Set_Font_Of_All_TextFrames Nothing "X" 被调用。它按预期工作，但出现以下问题：
1) 除了更改字体之外，我如何才能使此功能可用于其他操作？我真的必须复制粘贴所有这些吗？
2) 我能否像在我的函数中那样使用一个函数来遍历所有形状和组，而不是调用 set_font 子例程，而是填充一个包含对它能找到的所有形状的引用的列表？我可以将此列表传递给例如set_font 子程序（以及任何其他应该对所有形状执行操作的子程序）？
3) 为什么母版上的形状被排除在我的功能之外？
感谢评论，我发现这或多或少是要走的路。我 post 这里我 "ulitity function" 生成所有形状的集合（包括任意嵌套子组中的所有形状），可以在任何其他函数或子例程中使用和迭代。
贯穿当前演示文稿中所有幻灯片的简单版本（它还清楚地显示了该功能的运作方式）：
Function Get_All_Shapes(oShp As Shape, oColl As Collection)
' Go through all shapes on all slides. This is a recursive function. First call needs to pass "Nothing" to oShp and oColl.
' The collection oColl will be populated with all shapes (including all shapes in all groups) in the presentation.
' The return parameter will be the gradually populated collection.
' The recursion is necessary in order to go through groups.
Dim sld As Slide
Dim shp As Shape
Dim i As Integer
If oShp Is Nothing And oColl Is Nothing Then ' first function call
Set oColl = New Collection
For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
If shp.Type = msoGroup Then
Set oColl = Get_All_Shapes(shp, oColl) ' recursive call in case of group
Else
oColl.Add shp ' else add shape to collection
End If
Next shp
Next sld
' in case of recursive calls:
ElseIf oShp.Type = msoGroup Then
For i = 1 To oShp.GroupItems.Count()
Set shp = oShp.GroupItems.Item(i)
Set oColl = Get_All_Shapes(shp, oColl) ' another recursive call in case of group; will repeat this branch in case of subgroup
Next
Else
oColl.Add oShp ' else add shape to collection
End If
Set Get_All_Shapes = oColl ' set populated collection as function return parameter
End Function
这是一个更精致的版本，您可以选择是否仅使用选定的形状（和嵌套的子组）填充集合，以及是否应将带有自定义布局的母版幻灯片包含在集合中：
Function Get_All_Shapes_WIP(oShp As Shape, oColl As Collection, Optional onlySelected As Boolean = False, Optional includeMaster As Boolean = False)
' Go through all shapes on all slides. This is a recursive function. First call needs to pass "Nothing" to oShp and oColl.
' The collection oColl will be populated with all shapes (including all shapes in all groups) in the presentation.
' The return parameter will be the gradually populated collection.
' The recursion is necessary in order to go through groups.
' If onlySelected is True, only the selected shapes will be added to the collection.
' If includeMaster is True, shapes on the master slide and all custom layouts will be added to the collection. This behavior is not affected by the value of onlySelected.
Dim sld As Slide
Dim shp As Shape
Dim i As Integer
' first function call (main loops)
If oShp Is Nothing And oColl Is Nothing Then
Set oColl = New Collection
' presentation loops
If onlySelected = False Then ' all shapes on all slides
For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
If shp.Type = msoGroup Then
Set oColl = Get_All_Shapes_WIP(shp, oColl, onlySelected, includeMaster) ' recursive call in case of group
Else
oColl.Add shp ' else add shape to collection
End If
Next shp
Next sld
Else ' onlySelected = True
For Each shp In ActiveWindow.selection.ShapeRange
If shp.Type = msoGroup Then
Set oColl = Get_All_Shapes_WIP(shp, oColl, onlySelected, includeMaster) ' recursive call in case of group
Else
oColl.Add shp ' else add shape to collection
End If
Next shp
End If
' master loops
If includeMaster = True Then ' add also slide master shapes to the collection
' master shapes
For Each shp In ActivePresentation.SlideMaster.Shapes
If shp.Type = msoGroup Then
Set oColl = Get_All_Shapes_WIP(shp, oColl, onlySelected, includeMaster) ' recursive call in case of group
Else
oColl.Add shp ' else add shape to collection
End If
Next shp
' custom layouts shapes
For i = 1 To ActivePresentation.SlideMaster.CustomLayouts.Count()
For Each shp In ActivePresentation.SlideMaster.CustomLayouts.Item(i).Shapes
If shp.Type = msoGroup Then
Set oColl = Get_All_Shapes_WIP(shp, oColl, onlySelected, includeMaster) ' recursive call in case of group
Else
oColl.Add shp ' else add shape to collection
End If
Next shp
Next
End If
' recursive calls:
ElseIf oShp.Type = msoGroup Then
For i = 1 To oShp.GroupItems.Count()
Set shp = oShp.GroupItems.Item(i)
Set oColl = Get_All_Shapes_WIP(shp, oColl, onlySelected, includeMaster) ' another recursive call in case of group; will repeat this branch in case of subgroup
Next
Else
oColl.Add oShp ' else add shape to collection
End If
Set Get_All_Shapes_WIP = oColl ' set (partially) populated collection as function return parameter in every call
End Function
用法示例：
Sub Set_All_Fonts_To_Calibri()
' Sets the font of all text in all shapes in the presentation to "Calibri".
Dim coll As Collection: Set coll = Get_All_Shapes_WIP(Nothing, Nothing, onlySelected:=False, includeMaster:=True)
Dim shp As Shape
For Each shp In coll
Set_Font shp, "Calibri"
Next shp
End Sub