Удалить строку из текстового поля в слайде PowerPoint из папки – Компонент Error ActiveX не может создать объект

Когда вы запускаете макрос в Excel, вы забыли указать, откуда находится ActivePresentation . Он должен работать, если у вас есть 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 

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 

Я не могу объяснить ошибку, которую вы получаете. Я также ожидал, что код будет работать. Тем не менее, я наткнулся на эту проблему раньше и нашел следующее решение, которое (как ни странно) работает:

 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 

Примечание. Это решение использует раннее связывание вместо позднего связывания. Таким образом, вам нужно будет добавить ссылку на Microsoft PowerPoint xx.x Object Library