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

Question

我有一个项目，可以从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

Answer 1

以下是对我上述评论的解释（正如您的问题所示）。

我的幻灯片看起来像这样

如果您注意到并非所有形状都具有.TextFrame属性。所以你要做的就是找出你想要处理的形状。

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

Sub Sample()
    Dim shp As Shape

    For Each shp In ActivePresentation.Slides(1).Shapes
        Debug.Print shp.Name; "--"; shp.Type
    Next
End Sub

<强>截图

所以你可以尝试这样的事情。

注意：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