PowerPoint VBA逐形状设置文本加粗如何达到批量处理同等速度

场景设置 #

我使用的是16.0.4266.1001版本的PowerPoint，现有一个含8张相同幻灯片的演示文稿，每张幻灯片包含大量内部文本为1的矩形，每个矩形的文本加粗状态为随机设置（通过宏实现）。

测试方案 #

我测试了两种批量将所有矩形文本设为加粗的宏，运行效率差异明显：

• DoItSlow：逐个遍历所有形状，单独为每个形状设置加粗属性，运行耗时约20秒

  Sub DoItSlow()
      On Error Resume Next
      For Each sld In ActivePresentation.Slides
              For Each shp In sld.Shapes
                  shp.TextFrame2.TextRange.Font.Bold = msoTrue
              Next shp
      Next sld
  End Sub
  

• DoItFast：选中单页所有形状后一次性批量应用加粗属性，运行耗时仅约5秒

  Sub DoItFast()
      On Error Resume Next
      For Each sld In ActivePresentation.Slides
              sld.Shapes.Range.TextFrame2.TextRange.Font.Bold = msoTrue
      Next sld
  End Sub
  

核心疑问 #

如果需要根据每个矩形的实际情况单独判定加粗状态，不使用全选批量操作的前提下，能不能达到和批量处理相近的运行速度？

背景说明 #

最终需求不是将所有文本统一设为加粗，而是需要针对每个矩形单独判断加粗状态，同时要求尽可能做局部操作，不修改当前选区内容。

可以达到和批量处理接近的运行速度，核心逻辑是减少VBA和PowerPoint主程序的COM交互次数，两种可直接落地的优化方案如下：

方案1：先按规则分组再批量设置（效率最高） #

不需要逐个修改属性，只需要将相同加粗设置的形状归为一组，用ShapeRange批量处理，完全不影响当前选区，运行速度和DoItFast基本一致：

Sub BatchSetByGroup()
    ' 先关闭屏幕更新和事件减少运行开销
    Dim origScreenUpdating As MsoTriState
    origScreenUpdating = Application.ScreenUpdating
    Application.ScreenUpdating = msoFalse
    Dim origEnableEvents As Boolean
    origEnableEvents = Application.EnableEvents
    Application.EnableEvents = False
    
    Dim sld As Slide
    Dim shp As Shape
    Dim boldShapes() As Variant, nonBoldShapes() As Variant
    Dim boldCnt As Long, nonBoldCnt As Long
    
    For Each sld In ActivePresentation.Slides
        boldCnt = 0: nonBoldCnt = 0
        Erase boldShapes, nonBoldShapes
        
        ' 遍历所有形状，按自定义规则分组
        For Each shp In sld.Shapes
            If shp.HasTextFrame2 Then ' 先过滤无文本框的形状，避免无效报错
                ' 此处替换为你自己的加粗判定逻辑
                If 判定为需要加粗的条件 = True Then
                    ReDim Preserve boldShapes(boldCnt)
                    boldShapes(boldCnt) = shp.Name
                    boldCnt = boldCnt + 1
                Else
                    ReDim Preserve nonBoldShapes(nonBoldCnt)
                    nonBoldShapes(nonBoldCnt) = shp.Name
                    nonBoldCnt = nonBoldCnt + 1
                End If
            End If
        Next shp
        
        ' 批量设置每组的加粗属性，每页仅执行最多2次属性写入操作
        If boldCnt > 0 Then sld.Shapes.Range(boldShapes).TextFrame2.TextRange.Font.Bold = msoTrue
        If nonBoldCnt > 0 Then sld.Shapes.Range(nonBoldShapes).TextFrame2.TextRange.Font.Bold = msoFalse
    Next sld
    
    ' 恢复原有设置
    Application.ScreenUpdating = origScreenUpdating
    Application.EnableEvents = origEnableEvents
End Sub

方案2：优化逐个遍历的开销 #

如果业务逻辑确实需要完全逐个处理，关闭屏幕更新、禁用事件、提前过滤无效形状也能大幅提升速度，优化后耗时可降至原DoItSlow的1/3~1/2：

Sub OptimizedSingleSet()
    Dim origScreenUpdating As MsoTriState
    origScreenUpdating = Application.ScreenUpdating
    Application.ScreenUpdating = msoFalse
    Dim origEnableEvents As Boolean
    origEnableEvents = Application.EnableEvents
    Application.EnableEvents = False
    
    Dim sld As Slide
    Dim shp As Shape
    For Each sld In ActivePresentation.Slides
        For Each shp In sld.Shapes
            If shp.HasTextFrame2 Then ' 过滤无文本框的形状，替代无差别错误捕获减少开销
                ' 替换为你的自定义判定逻辑
                shp.TextFrame2.TextRange.Font.Bold = IIf(判定为需要加粗的条件, msoTrue, msoFalse)
            End If
        Next shp
    Next sld
    
    Application.ScreenUpdating = origScreenUpdating
    Application.EnableEvents = origEnableEvents
End Sub

不要使用无差别的On Error Resume Next，无效的错误捕获会增加额外运行开销，提前判断形状是否有文本框即可避免报错。

内容的提问来源于stack exchange，提问作者phimuemue