Удалить слайды Powerpoint, содержащие ключевые слова, используя VBA - PullRequest
Новая
       10

Удалить слайды Powerpoint, содержащие ключевые слова, используя VBA

0 голосов
/ 27 февраля 2019

У меня есть папка с 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

Я могу открыть все пункты в папке.Я не могу удалить слайды, используя мои конкретные ключевые слова.

1 Ответ

0 голосов
/ 27 февраля 2019

Я немного изменил ваш список, и он работает для меня: 

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
...