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中运行宏时，您忘记说 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

我无法解释你得到的错误。我也希望代码能够运行。然而，我之前偶然发现了这个问题，并找到了以下解决方案（奇怪地）：

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的引用。

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

2 个答案: