vba - 从文件夹中的PowerPoint幻灯片中的文本框中删除字符串-错误ActiveX组件无法创建对象

Question

我想遍历文件夹中的所有 ppt，如果在任何幻灯片的任何文本框中找到一个字符串，则删除该字符串。

我是使用 powerpoint 幻灯片的新手，因此需要一些技巧和建议如何使用它。

Option Compare Text
Option Explicit

Sub Test()

Dim Sld As Slide, Shp As Shape
Dim strFileName As String
Dim strFolderName As String
Dim PP As Presentation
Dim strf As String

'String to be deleted.
strf = InputBox("Enter the string.", "Delete String from PPT.", "AAAAA")

'Opens a PowerPoint Document from Excel
Dim objPPT As Object
Set objPPT = CreateObject("PowerPoint.Application")
objPPT.Visible = True


'set default directory here if needed
strFolderName = "C:\Users\Desktop\Files"
strFileName = Dir(strFolderName & "\*.ppt*")

Do While Len(strFileName) > 0

    objPPT.Presentations.Open strFolderName & "\" & strFileName
    objPPT.Presentations.Activate

    For Each Sld In ActivePresentation.Slides     'Error - ActiveX Component can't create object.
        For Each Shp In Sld.Shapes
          Select Case Shp.Type
            Case MsoShapeType.msoTextBox
              Debug.Print Sld.Name, Shp.Name, Shp.TextFrame.TextRange.Text
            Case Else
              Debug.Print Sld.Name, Shp.Name, "This is not a text box"
          End Select
        Next Shp
    Next Sld

    objPPT.Presentations.Close
    strFileName = Dir

Loop

End Sub

Answer 1

当您在 Excel 中运行宏时，您忘记了 的位置。事件演示 来自。如果您有 objPPT.ActivePresentation.Slides，它应该可以工作。 .无论如何，您可以尝试以下修改后的代码:

'Option Compare Text
Option Explicit

Sub Test()

    'Dim Sld As Slide, Shp As Shape ' <-- Excel doesn't know Slide if Reference not added
    Dim Sld As Object, Shp As Object
    Dim strFileName As String
    Dim strFolderName As String
    'Dim PP As Presentation
    Dim PP As Object ' Use this Presentation Object!
    Dim strf As String

    'String to be deleted.
    strf = InputBox("Enter the string.", "Delete String from PPT.", "AAAAA")

    'Opens a PowerPoint Document from Excel
    Dim objPPT As Object
    Set objPPT = CreateObject("PowerPoint.Application")
    objPPT.Visible = True ' <-- don't need this, for debug only

    'set default directory here if needed
    strFolderName = "C:\Users\Desktop\Files"
    strFileName = Dir(strFolderName & "\*.ppt*")

    Do While Len(strFileName) > 0
        'objPPT.Presentations.Open strFolderName & "\" & strFileName
        Set PP = objPPT.Presentations.Open(strFolderName & "\" & strFileName)
        'objPPT.Presentations.Activate
        PP.Activate ' <-- don't need this, for debug only
        'For Each Sld In ActivePresentation.Slides     'Error - ActiveX Component can't create object.
        ' Should work if it's "objPPT.ActivePresentation.Slides"
        For Each Sld In PP.Slides
            For Each Shp In Sld.Shapes
                With Shp
                    Select Case .Type
                        Case MsoShapeType.msoTextBox
                            If InStr(1, .TextFrame.TextRange.Text, strf, vbTextCompare) > 0 Then
                                Debug.Print Sld.Name, .Name, .TextFrame.TextRange.Text
                            Else
                                Debug.Print Sld.Name, .Name, """" & strf & """ not found in text body"
                            End If
                        Case Else
                            Debug.Print Sld.Name, .Name, "This is not a text box"
                    End Select
                End With
            Next Shp
        Next Sld

        'objPPT.Presentations.Close
        PP.Close
        Set PP = Nothing
        strFileName = Dir
    Loop

End Sub

更新 - 允许处理已经打开的文件和一些调整:

Option Explicit

Sub Test()

    Const strFolderName = "C:\Users\Desktop\Files\"

    Dim objPPT As Object, PP As Object, Sld As Object, Shp As Object
    Dim strFileName As String
    Dim strf As String

    'String to be deleted.
    strf = InputBox("Enter the string.", "Delete String from PPT.", "AAAAA")
    If Len(Trim(strf)) = 0 Then Exit Sub ' Exit if blank text returned

    'Opens a PowerPoint Document from Excel
    Set objPPT = CreateObject("PowerPoint.Application")

    'set default directory here if needed
    strFileName = Dir(strFolderName & "*.ppt*")

    Do While Len(strFileName) > 0
        On Error Resume Next
        ' Try to get existing one with same name
        Set PP = objPPT.Presentations(strFileName)
        ' If not opened, try open it
        If PP Is Nothing Then Set PP = objPPT.Presentations.Open(strFolderName & strFileName)
        On Error GoTo 0
        ' Process the Presentation Slides if it's opened
        If PP Is Nothing Then
            Debug.Print "Cannot open file! """ & strFolderName & strFileName & """"
        Else
            Application.StatusBar = "Processing PPT file: " & PP.FullName
            Debug.Print String(50, "=")
            Debug.Print "PPT File: " & PP.FullName
            For Each Sld In PP.Slides
                For Each Shp In Sld.Shapes
                    With Shp
                        If .Type = MsoShapeType.msoTextBox Then
                            If InStr(1, .TextFrame.TextRange.Text, strf, vbTextCompare) > 0 Then
                                Debug.Print Sld.Name, .Name, .TextFrame.TextRange.Text
                            Else
                                Debug.Print Sld.Name, .Name, """" & strf & """ not found in text body"
                            End If
                        End If
                    End With
                Next Shp
            Next Sld
            PP.Close ' Close the Presentation
            Set PP = Nothing
        End If
        strFileName = Dir
    Loop
    Application.StatusBar = False
    ' Quit PowerPoint app
    objPPT.Quit
    Set objPPT = Nothing
End Sub