Vba 使用excel中的宏查找和替换音频ppt中的文本

我有一个项目要从excel中查找并替换powerpoint中的单词，然后保存powerpoint。我的代码运行良好。但当ppt播放mp3时，它会出现错误。请查看代码并告诉我应该做什么更改

          Sub pptopen()

    Dim a  As Integer
    For a = 2 To 4

   Dim pptApp As PowerPoint.Application
   Dim pptPres As PowerPoint.Presentation
   Dim pptSlide As PowerPoint.Slide
   Dim i As Integer, strString As String
       Set pptApp = CreateObject("PowerPoint.Application")
       Set pptPres = pptApp.Presentations.Add(msoTrue) ' create a new presentation

       Set pptPres = pptApp.Presentations.Open("D:\BirminghamAL.pptx")
       Dim oSld As Slide
       Dim oTxtRng As TextRange
       Dim oTmpRng As TextRange
       Dim strWhatReplace As String, strReplaceText As String

        ' write find text
       strWhatReplace = "Birmingham"
        ' write change text
       strReplaceText = Cells(a, 1).Value

        ' go during each slides
       For Each oSld In pptPres.Slides
            ' go during each shapes and textRanges
           For Each oshp In oSld.Shapes
           If oshp.Type = 14 Or oshp.Type = 17 Then
                ' replace in TextFrame
               Set oTxtRng = oshp.TextFrame.TextRange
               Set oTmpRng = oTxtRng.Replace( _
               FindWhat:=strWhatReplace, _
               Replacewhat:=strReplaceText, _
               WholeWords:=True)
               End If


               Do While Not oTmpRng Is Nothing

                   Set oTxtRng = oTxtRng.Characters _
                   (oTmpRng.Start + oTmpRng.Length, oTxtRng.Length)
                   Set oTmpRng = oTxtRng.Replace( _
                   FindWhat:=strWhatReplace, _
                   Replacewhat:=strReplaceText, _
                   WholeWords:=True)

               Loop
           Next oshp
       Next oSld
       Dim strWhatReplace1 As String, strReplaceText1 As String

        ' write find text
       strWhatReplace1 = "AL"
        ' write change text
       strReplaceText1 = Cells(a, 2).Value

        ' go during each slides
       For Each oSld In pptPres.Slides
            ' go during each shapes and textRanges
           For Each oshp In oSld.Shapes
                 If oshp.Type = 14 Or oshp.Type = 17 Then
                ' replace in TextFrame
               Set oTxtRng = oshp.TextFrame.TextRange
               Set oTmpRng = oTxtRng.Replace( _
               FindWhat:=strWhatReplace1, _
               Replacewhat:=strReplaceText1, _
               WholeWords:=True)
                 End If
               Do While Not oTmpRng Is Nothing

                   Set oTxtRng = oTxtRng.Characters _
                   (oTmpRng.Start + oTmpRng.Length, oTxtRng.Length)
                   Set oTmpRng = oTxtRng.Replace( _
                   FindWhat:=strWhatReplace1, _
                   Replacewhat:=strReplaceText1, _
                   WholeWords:=True)

               Loop
           Next oshp
       Next oSld

      pptPres.SaveAs ("D:\change\" & strReplaceText & "." & strReplaceText1 & ".pptx")

       Next a

   End Sub

---

下面是对我上述评论的解释（就在你问题的下方）

我的幻灯片看起来像这样

如果您注意到并非所有形状都具有

.TextFrame

属性。所以你所要做的就是找出你想要处理的形状

下面是一个非常基本的代码，用于检查幻灯片上的所有形状

屏幕截图

你可以试试这样的

注意：14只是一个例子。您需要决定要处理哪种形状

For Each oSld In pptPres.Slides
    For Each oshp In oSld.Shapes
        If oshp.Type = 14 Then
            '~~> Rest of your code
        End If
    Next oshp
Next oSld

跟进

我刚刚试过这个代码，它是有效的

Option Explicit

Sub pptopen()
    Dim pptApp As New PowerPoint.Application
    Dim pptPres As PowerPoint.Presentation
    Dim pptSlide As PowerPoint.Slide, oSld As PowerPoint.Slide
    Dim oshp As PowerPoint.Shape

    Dim oTxtRng As TextRange, oTmpRng As TextRange
    Dim oTxtRng1 As TextRange, oTmpRng1 As TextRange

    Dim strString As String, strWhatReplace As String, strReplaceText As String
    Dim strWhatReplace1 As String, strReplaceText1 As String

    Dim a As Integer, i As Integer

    Set pptPres = pptApp.Presentations.Open("D:\BirminghamAL.pptx")

    For a = 2 To 4
        ' write find text
        strWhatReplace = "Birmingham"
        ' write change text
        strReplaceText = Cells(a, 1).Value
        ' write find text
        strWhatReplace1 = "AL"
        ' write change text
        strReplaceText1 = Cells(a, 2).Value

        ' go during each slides
        For Each oSld In pptPres.Slides
            ' go during each shapes and textRanges
            For Each oshp In oSld.Shapes
                If oshp.Type = 14 Or oshp.Type = 17 Then
                    ' replace in TextFrame
                    Set oTxtRng = oshp.TextFrame.TextRange
                    Set oTmpRng = oTxtRng.Replace(FindWhat:=strWhatReplace, _
                                  Replacewhat:=strReplaceText, WholeWords:=True)

                    Do While Not oTmpRng Is Nothing
                       Set oTxtRng = oTxtRng.Characters(oTmpRng.Start + oTmpRng.Length, oTxtRng.Length)
                       Set oTmpRng = oTxtRng.Replace(FindWhat:=strWhatReplace, Replacewhat:=strReplaceText, WholeWords:=True)
                    Loop

                    ' replace in TextFrame
                    Set oTxtRng1 = oshp.TextFrame.TextRange
                    Set oTmpRng1 = oTxtRng1.Replace(FindWhat:=strWhatReplace1, _
                                  Replacewhat:=strReplaceText1, WholeWords:=True)

                    Do While Not oTmpRng1 Is Nothing
                       Set oTxtRng1 = oTxtRng1.Characters(oTmpRng1.Start + oTmpRng1.Length, oTxtRng1.Length)
                       Set oTmpRng1 = oTxtRng1.Replace(FindWhat:=strWhatReplace1, Replacewhat:=strReplaceText1, WholeWords:=True)
                    Loop

                End If
            Next oshp
        Next oSld

        pptPres.SaveAs Filename:="D:\change\" & strReplaceText & "_" & strReplaceText1 & ".pptx", FileFormat:=ppSaveAsDefault
    Next a
End Sub

---

如果有一个没有mp3的powerpoint，那么它可以正常工作。只要我调用audio mp3，它就会为oSld.Shapes中的每个oShp提供函数错误

。您必须确保在此行之后和此行之前
设置oTxtRng=oShp.TextFrame.TextRange
，该形状是TextboxSiddarth sir，但尚未运行。在行中抛出错误你可以给我你的电子邮件id，这样我就可以把整个fileppt文件发送到这里文件在这里我的代码中哪一行给你错误？我正在下载文件
Option Explicit

Sub pptopen()
    Dim pptApp As New PowerPoint.Application
    Dim pptPres As PowerPoint.Presentation
    Dim pptSlide As PowerPoint.Slide, oSld As PowerPoint.Slide
    Dim oshp As PowerPoint.Shape

    Dim oTxtRng As TextRange, oTmpRng As TextRange
    Dim oTxtRng1 As TextRange, oTmpRng1 As TextRange

    Dim strString As String, strWhatReplace As String, strReplaceText As String
    Dim strWhatReplace1 As String, strReplaceText1 As String

    Dim a As Integer, i As Integer

    Set pptPres = pptApp.Presentations.Open("D:\BirminghamAL.pptx")

    For a = 2 To 4
        ' write find text
        strWhatReplace = "Birmingham"
        ' write change text
        strReplaceText = Cells(a, 1).Value
        ' write find text
        strWhatReplace1 = "AL"
        ' write change text
        strReplaceText1 = Cells(a, 2).Value

        ' go during each slides
        For Each oSld In pptPres.Slides
            ' go during each shapes and textRanges
            For Each oshp In oSld.Shapes
                If oshp.Type = 14 Or oshp.Type = 17 Then
                    ' replace in TextFrame
                    Set oTxtRng = oshp.TextFrame.TextRange
                    Set oTmpRng = oTxtRng.Replace(FindWhat:=strWhatReplace, _
                                  Replacewhat:=strReplaceText, WholeWords:=True)

                    Do While Not oTmpRng Is Nothing
                       Set oTxtRng = oTxtRng.Characters(oTmpRng.Start + oTmpRng.Length, oTxtRng.Length)
                       Set oTmpRng = oTxtRng.Replace(FindWhat:=strWhatReplace, Replacewhat:=strReplaceText, WholeWords:=True)
                    Loop

                    ' replace in TextFrame
                    Set oTxtRng1 = oshp.TextFrame.TextRange
                    Set oTmpRng1 = oTxtRng1.Replace(FindWhat:=strWhatReplace1, _
                                  Replacewhat:=strReplaceText1, WholeWords:=True)

                    Do While Not oTmpRng1 Is Nothing
                       Set oTxtRng1 = oTxtRng1.Characters(oTmpRng1.Start + oTmpRng1.Length, oTxtRng1.Length)
                       Set oTmpRng1 = oTxtRng1.Replace(FindWhat:=strWhatReplace1, Replacewhat:=strReplaceText1, WholeWords:=True)
                    Loop

                End If
            Next oshp
        Next oSld

        pptPres.SaveAs Filename:="D:\change\" & strReplaceText & "_" & strReplaceText1 & ".pptx", FileFormat:=ppSaveAsDefault
    Next a
End Sub