1

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

1 回答 1

0

这是对我上述评论的解释（就在您的问题下方）。

我的幻灯片看起来像这样

在此处输入图像描述

如果您注意到并非所有形状都具有该.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
于 2013-04-11T10:45:26.090 回答