使用VBA删除包含关键字的Powerpoint幻灯片

Question

我有一个包含10个PowerPoint演示文稿的文件夹。每个演示文稿有20-25张幻灯片。

假设我有一个关键字“CX404”，“AR50”。宏应删除10个演示文稿中具有该关键字的所有幻灯片。

Public Sub DoFiles()
    Dim strFileName As String
    Dim strFolderName As String
    Dim PP As Presentation
    'set default directory here if needed
    strFolderName = "D:\Users\Desktop\Shaon\pptss"
    strFileName = Dir(strFolderName & "\*.pptx*")
    Do While Len(strFileName) > 0
        Set PP = Presentations.Open(strFolderName & "\" & strFileName)
        'your code
        Dim oSld As Slide
        Dim oShp As Shape
        Dim L As Long
        For L = ActivePresentation.Slides.Count To 1 Step -1
            Set oSld = ActivePresentation.Slides(L)
            For Each oShp In oSld.Shapes
                If oShp.HasTextFrame Then
                    Select Case UCase(oShp.TextFrame.TextRange)
                    Case Is = "CX400", "AR50"
                        oSld.Delete
                    Case Else
                       'not found
                End Select
                End If
            Next oShp
        Next L
        PP.Close
        strFileName = Dir
    Loop
End Sub

我可以打开文件夹中的所有ppts。我无法使用特定关键字删除幻灯片。

Answer 1

我稍微修改了你的列表，它对我有用：

Option Explicit
Public Sub DoFiles()
    Dim strFileName As String
    Dim strFolderName As String
    Dim PP As Presentation
    Dim sText As String
    strFolderName = "D:\111\"
    strFileName = Dir(strFolderName & "\*.pptx*")
    sText = "TEST"
    Do While Len(strFileName) > 0
        Set PP = Presentations.Open(strFolderName & "\" & strFileName)
        Dim oSld As Slide
        Dim oShp As Shape
        Dim L As Long
        For L = ActivePresentation.Slides.Count To 1 Step -1
        Set oSld = ActivePresentation.Slides(L)
             For Each oShp In oSld.Shapes
             On Error Resume Next
                If oShp.HasTextFrame Then
                    If UBound(Split(oShp.TextFrame.TextRange, sText)) > 0 Then
                    PP.Slides(L).Delete
                    End If
                End If
             Next oShp
        Next L
        PP.Save
        PP.Close
        strFileName = Dir
    Loop
End Sub