VBA Powerpoint：删除删除线文本

Question

我发现一些代码可以很好地删除powerpoint文件中的任何“删除线”文本..但它只适用于表格...有人可以帮助我修改代码以适用于powerpoint中的任何形状类型（例如文本框）等）请问？ （注意：由于文本框中的某些文本通常带有删除线，而其他文本则没有，我确实需要这种逐字符的方法）

Sub testIterateShapesType()
Dim sl As Slide, sh As Shape, tbl As Table, i As Long, j As Long, k As Long
     For Each sl In ActivePresentation.Slides
        For Each sh In sl.Shapes
            If sh.Type = msoTable Then
                Set tbl = sh.Table
                For i = 1 To tbl.Rows.Count
                    For j = 1 To tbl.Columns.Count
                        For k = tbl.Cell(i, j).Shape.TextFrame2.TextRange.Characters.Count To 1 Step -1
                            If tbl.Cell(i, j).Shape.TextFrame2.TextRange.Characters(k, 1).Font.Strikethrough Then
                                tbl.Cell(i, j).Shape.TextFrame2.TextRange.Characters(k, 1) = ""
                            End If
                        Next k
                    Next j
                Next i
            End If
        Next
     Next
End Sub

Answer 1

请尝试下一个改编的代码并发送一些反馈：

Sub DeleteStrikeThroughChars()
     Dim sl As Slide, sh As Shape, tbl As table, i As Long, j As Long, k As Long
     For Each sl In ActivePresentation.Slides
        For Each sh In sl.Shapes
            If sh.Type = msoTextBox Or sh.Type = msoAutoShape Then
                For k = sh.TextFrame2.TextRange.Characters.Count To 1 Step -1
                    If sh.TextFrame2.TextRange.Characters(k, 1).Font.Strikethrough Then
                        sh.TextFrame2.TextRange.Characters(k, 1) = ""
                    End If
                Next k
            End If
            If sh.Type = msoTable Then
                Set tbl = sh.table
                For i = 1 To tbl.Rows.Count
                    For j = 1 To tbl.Columns.Count
                        For k = tbl.Cell(i, j).Shape.TextFrame2.TextRange.Characters.Count To 1 Step -1
                            If tbl.Cell(i, j).Shape.TextFrame2.TextRange.Characters(k, 1).Font.Strikethrough Then
                                tbl.Cell(i, j).Shape.TextFrame2.TextRange.Characters(k, 1) = ""
                            End If
                        Next k
                    Next j
                Next i
            End If
        Next
     Next
End Sub

如果有遗漏，请注明相应形状是什么类型...

Answer 2

基本上，对于所有具有文本的形状，删除某些字符（例如所有带删除线格式的字符）的逻辑是相同的。

您需要检查 2 件事：

某些形状没有文本，因此您必须跳过它们：了解形状是否有文本很容易，只需检查属性

HasTextFrame

即可。如果这是错误的，请跳过它。

某些形状具有包含文本的子形状。我至少知道三种情况：

• 表格（这是您的代码已经处理的内容）
• 形状组。可以通过循环所有 GroupItems（即该组内形状的集合）来处理组
• 图表。图表非常特别，我会直接跳过它们。

我所做的是将您拥有的代码拆分为单个例程。

• processPresentation

  循环播放当前演示文稿的所有幻灯片

• processSlide

  循环遍历幻灯片的所有形状

• processShape

  处理不同的形状类型

• processText

  处理单个形状的文本

这使得更容易理解代码（你没有那么多嵌套循环），并且每个例程仅服务于一个目的。它还使测试变得更加容易：例如，在测试期间，我用一张具有几种不同形状的幻灯片（并删除文本）进行了演示，复制该幻灯片，然后仅运行第一张幻灯片的代码。测试后，我只是复制了副本，并准备好所有删除文本以供下一次测试。

如果仔细观察，与您的代码相比，只有

processShape

中的部分确实是新的。

Option Explicit

Sub ProcessPresentation()
    Dim sl As Slide
    For Each sl In ActivePresentation.Slides
        processSlide sl
    Next sl
End Sub

Sub test()
    processSlide ActivePresentation.Slides(1)
End Sub

Sub processSlide(sl As Slide)
    Dim sh As Shape
    For Each sh In sl.Shapes
        processShape sh
    Next
End Sub

Sub processShape(sh As Shape)
    Dim child As Shape
    Select Case sh.Type
        Case msoGroup
            ' For groups: Process all shapes within group
            For Each child In sh.GroupItems
                processShape child
            Next
        Case msoChart
            ' Debug.Print "Chart"
        Case msoTable
            ' For tables: Process all cells
            Dim row As Long, col As Long
            For row = 1 To sh.Table.Rows.Count
                For col = 1 To sh.Table.Rows(row).Cells.Count
                    Dim cell As cell
                    Set cell = sh.Table.Rows(row).Cells(col)
                    processText cell.Shape
                Next
            Next
        Case Else
            ' Simple Shape
            processText sh
    End Select
End Sub

Sub processText(sh As Shape)
    If Not sh.HasTextFrame Then
        Debug.Print sh.Name; " has no text"
        Exit Sub
    End If
    
    Dim k As Long
    For k = sh.TextFrame2.TextRange.Characters.Count To 1 Step -1
        If sh.TextFrame2.TextRange.Characters(k, 1).Font.Strikethrough Then
            sh.TextFrame2.TextRange.Characters(k, 1) = ""
        End If
    Next k
End Sub