使用excel中的宏查找並替換音頻ppt中的文本

Question

我有一個項目可以從excel中查找和替換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財產。所以你所要做的就是找出你想要處理的形狀。

這是一個非常基本的代碼來檢查什麼在你的幻燈片（S）

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