从文件夹的 powerpoint 幻灯片中的文本框中删除字符串 - 错误 ActiveX 组件无法创建对象
Delete string from textbox in powerpoint slide from a folder - Error ActiveX component can't create object
我想遍历一个文件夹中的所有 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
我无法解释您遇到的错误。我也希望代码能够工作。然而，我之前偶然发现了这个问题并找到了以下（奇怪地）有效的解决方案：
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.
的引用
由于您是 运行 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
更新 - 允许处理已打开的文件和一些调整：
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
我想遍历一个文件夹中的所有 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
我无法解释您遇到的错误。我也希望代码能够工作。然而，我之前偶然发现了这个问题并找到了以下（奇怪地）有效的解决方案：
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.
由于您是 运行 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
更新 - 允许处理已打开的文件和一些调整：
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