如何修改VBA代码实现PowerPoint全形状类型删除线文本移除？

原代码仅针对PowerPoint表格中的删除线文本，要让它作用于所有带文本的形状（文本框、艺术字、群组内形状等），可以按以下方式修改：

核心改动说明 #

• 去掉仅处理表格的判断，改为检查所有包含可编辑文本的形状
• 新增群组形状的处理逻辑（群组内的子形状也可能有文本）
• 把文本处理逻辑抽成通用子过程，避免重复代码
• 保持逐字符倒序处理的逻辑（正向删除会导致字符索引错乱）

修改后的完整代码 #

Sub RemoveStrikethroughFromAllShapes()
    Dim sl As Slide
    Dim sh As Shape
    
    '遍历所有幻灯片
    For Each sl In ActivePresentation.Slides
        '遍历当前幻灯片的所有形状
        For Each sh In sl.Shapes
            '处理不同类型的形状
            Select Case sh.Type
                Case msoGroup
                    '处理群组内的子形状
                    ProcessGroupShapes sh
                Case msoTable
                    '处理表格单元格内的文本
                    ProcessTable sh.Table
                Case Else
                    '处理普通带文本的形状（文本框、艺术字等）
                    If sh.HasTextFrame And sh.TextFrame.HasText Then
                        ProcessTextRange sh.TextFrame2.TextRange
                    End If
            End Select
        Next sh
    Next sl
End Sub

'处理群组内的子形状
Private Sub ProcessGroupShapes(groupSh As Shape)
    Dim subSh As Shape
    For Each subSh In groupSh.GroupItems
        Select Case subSh.Type
            Case msoGroup
                ProcessGroupShapes subSh '递归处理嵌套群组
            Case msoTable
                ProcessTable subSh.Table
            Case Else
                If subSh.HasTextFrame And subSh.TextFrame.HasText Then
                    ProcessTextRange subSh.TextFrame2.TextRange
                End If
        End Select
    Next subSh
End Sub

'处理表格内的所有单元格文本
Private Sub ProcessTable(tbl As Table)
    Dim i As Long, j As Long
    For i = 1 To tbl.Rows.Count
        For j = 1 To tbl.Columns.Count
            If tbl.Cell(i, j).Shape.HasTextFrame And tbl.Cell(i, j).Shape.TextFrame.HasText Then
                ProcessTextRange tbl.Cell(i, j).Shape.TextFrame2.TextRange
            End If
        Next j
    Next i
End Sub

'通用文本处理：逐字符删除带删除线的内容
Private Sub ProcessTextRange(txtRng As TextRange2)
    Dim k As Long
    '倒序遍历字符，避免删除后索引错乱
    For k = txtRng.Characters.Count To 1 Step -1
        If txtRng.Characters(k, 1).Font.Strikethrough Then
            txtRng.Characters(k, 1) = ""
        End If
    Next k
End Sub

代码使用说明 #

1. 打开PowerPoint，按Alt + F11打开VBA编辑器
2. 插入一个新模块，把上述代码粘贴进去
3. 运行RemoveStrikethroughFromAllShapes宏，即可批量移除所有形状中的删除线文本

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