从文本文件夹中删除PowerPoint文本框中的string – 错误的ActiveX组件不能创build对象

我想从一个文件夹中遍历所有的ppt，并删除任何幻灯片中的任何文本框中find的string。

我是新来的幻灯片工作，因此需要一些技巧和build议如何使用它。

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中运行macros时，忘记了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 

---

更新 – 允许处理已打开的文件和一些调整：

 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

我无法解释你得到的错误。 我也会期望的代码工作。 然而，我偶然发现了这个问题，并发现了下面这个（奇怪的）解决scheme：

 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 

注意：此解决scheme使用早期绑定而不是后期绑定。 所以，您将需要添加对Microsoft PowerPoint xx.x Object Library的引用。