Delete string from textbox in powerpoint slide from a folder - Error ActiveX component can't create object

Question

I would like to loop through all the ppt from a folder and delete a string if found in any textbox in any slide.

I am new to working with powerpoint slides hence need some tips and advice how to work with it.

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

As you are running the macro in Excel, you forgot to say where the ActivePresentation is from. It should work if you have objPPT.ActivePresentation.Slides. Anyway, you can try below revised code:

'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

---

UPDATE

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

Answer 2

I cannot explain the error you are getting. I also would have expected the code to work. Yet, I stumbled upon this problem before and found the following solution which (strangely) works:

Option Compare Text
Option Explicit

Sub Test()

Dim Sld As Long, Shp As Long
Dim strFileName As String
Dim strFolderName As String
Dim PP As PowerPoint.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 PowerPoint.Application
Set objPPT = New 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

    Set PP = objPPT.Presentations.Open(strFolderName & "\" & strFileName)
    'objPPT.Presentations.Activate

    For Sld = 1 To PP.Slides.Count
        For Shp = 1 To PP.Slides.Item(Sld).Shapes.Count
            With PP.Slides.Item(Sld).Shapes.Item(Shp)
                Select Case .Type
                Case MsoShapeType.msoTextBox
                    Debug.Print .Name, .Name, .TextFrame.TextRange.Text
                Case Else
                    Debug.Print .Name, .Name, "This is not a text box"
                End Select
            End With
        Next Shp
    Next Sld

    PP.Close
    Set PP = Nothing
    strFileName = Dir

Loop

objPPT.Quit
Set objPPT = Nothing

End Sub

Note: this solution uses early binding instead of late binding. So, you will need to add a reference to Microsoft PowerPoint xx.x Object Library.