下标越界:word中生成ppt

weiyingde

Sub word中生成ppt()
    Dim p As Range, doc As Document, arr()
    Dim appt As New PowerPoint.Application
    Set doc = ActiveDocument
    doc.Bookmarks("\StartOfDoc").Select
    Do
        n = n + 1: ReDim Preserve arr(1 To n)
        If n = 1 Then
            Selection.MoveEnd 5, 10
            Set p = Selection.Range
            arr(1) = p.Text
        Else
            p.Collapse 0: p.Select
            Selection.MoveEnd 5, 10
            Set p = Selection.Range
            arr(n) = p.Text
        End If
    Loop Until p.End = doc.Content.End
   
    Set apre = appt.Presentations.Add
    Set cuslayout = apre.SlideMaster.CustomLayouts(7)
    For i = 1 To UBound(arr) + 1
        appt.ActivePresentation.Slides.AddSlide i, cuslayout
    Next
         w = apre.PageSetup.SlideWidth 'appt.ActivePresentation
         h = apre.PageSetup.SlideHeight
        For j = 1 To UBound(arr) + 1
           With apre.Slides(j).Shapes.AddTextbox(1, Left:=5, Top:=5, Width:=w -10, Height:=h -10)
               With .TextFrame.TextRange
                    .Text = arr(j - 1)
                    With .Font
                         .NameFarEast = "黑体"
                         .Size = 20
                         .Color.RGB = RGB(200, 128, 128)
                    End With
               End With
            End With
        Next
   apre.SaveAs ThisWorkbook.Path & "\文本.pptx"
   apre.SlideShowSettings.Run
End Sub

weiyingde

在求大虾过目斧正，静候佳音！！

weiyingde

自我已经解决，又出现了新的问题。

duquancai

weiyingde 发表于 2017-4-26 07:28
自我已经解决，又出现了新的问题。

Sub wordvba中生成ppt()
    Dim appt As Object, arr(), apre As Object, cuslayout As Object
    ActiveDocument.Bookmarks("\StartOfDoc").Select
    With Selection
        Do
            n = n + 1: ReDim Preserve arr(1 To n)
            .Collapse 0: .MoveEnd 5, 10: arr(n) = .Text
        Loop Until .End = ActiveDocument.Content.End
    End With
    Set appt = CreateObject("Powerpoint.application")
    Set apre = appt.Presentations.Add(0)
    Set cuslayout = apre.SlideMaster.CustomLayouts(7)
    For i = 1 To UBound(arr)
        apre.Slides.AddSlide i, cuslayout
    Next
    w = apre.PageSetup.SlideWidth
    h = apre.PageSetup.SlideHeight
    For j = 1 To UBound(arr)
        With apre.Slides(j).Shapes.AddTextbox(1, Left:=5, Top:=5, Width:=w - 10, Height:=h - 10)
            With .TextFrame.TextRange
                .Text = arr(j)
                With .Font
                    .NameFarEast = "黑体"
                    .Size = 20
                    .Color.RGB = RGB(200, 128, 128)
                End With
            End With
        End With
    Next
    apre.SaveAs ThisDocument.Path & "\文本.pptx"
    apre.Close: appt.Quit
    MsgBox "处理完毕！"
End Sub

weiyingde

duquancai 发表于 2017-4-26 08:07
Sub wordvba中生成ppt()
    Dim appt As Object, arr(), apre As Object, cuslayout As Object
    Ac ...

谢谢，这个我自己已经解决，但是又出新问题了。
不知系统原因还是word2010自身原因。
图如下：

weiyingde

weiyingde 发表于 2017-4-26 09:05
谢谢，这个我自己已经解决，但是又出新问题了。
不知系统原因还是word2010自身原因。
图如下：

已经妥善自我解决了，多谢杜老师，一键完成了由word转换为ppt并添加音效以及切换、自动播放等自动化进程。
没有杜先生的第一步进程的实现，就没有这个自我感觉良好的程序。
再次谢谢杜先生

jiminyanyan

weiyingde 发表于 2017-4-26 10:32
已经妥善自我解决了，多谢杜老师，一键完成了由word转换为ppt并添加音效以及切换、自动播放等自动化进程 ...

不错不错,发个附件出来让我们学习一下......

weiyingde

jiminyanyan 发表于 2017-4-26 13:01
不错不错,发个附件出来让我们学习一下......

除了你给的那段代码外，其余的十分的简单。
因为插入的音效和音频文件的地址在我的电脑上，所以假如要测试效果，一定要在相关的文件夹放置代码规定的格式的文件。

weiyingde

jiminyanyan 发表于 2017-4-26 13:01
不错不错,发个附件出来让我们学习一下......

看能不能简化一下。
Sub word中生成ppt()
    Dim p As Range, Doc As Document, arr()
    Dim Appt As New PowerPoint.Application
    Set Doc = ActiveDocument
    Doc.Bookmarks("\StartOfDoc").Select
    Do
        n = n + 1: ReDim Preserve arr(1 To n)
        If n = 1 Then
            Selection.MoveEnd 5, 6
            Set p = Selection.Range
            Set arr(1) = p.Duplicate
        Else
            p.Collapse 0: p.Select
            Selection.MoveEnd 5, 6
            Set p = Selection.Range
            Set arr(n) = p.Duplicate
        End If
    Loop Until p.End = Doc.Content.End
   
   
    jpth = "F:\音视频\汽车音乐\佛音\"
    xpth = "C:\Program Files\Microsoft Office\Office14\MEDIA\"
    wpth = "D:\H\Ofenused\音效\精选\"
    Set d1 = CreateObject("scripting.dictionary")
    Set d2 = CreateObject("scripting.dictionary")
    Set d3 = CreateObject("scripting.dictionary")
    nm1 = Dir(jpth & "*.mp3")
       Do While nm1 <> ""
          d1(jpth & nm1) = ""
          nm1 = Dir
       Loop
          k1 = d1.keys
    nm2 = Dir(xpth & "*.WAV")
       Do While nm2 <> ""
          d2(xpth & nm2) = ""
          nm2 = Dir
       Loop
          K2 = d2.keys
    nm3 = Dir(wpth & "*.WAV")
       Do While nm3 <> ""
          d3(wpth & nm3) = ""
          nm3 = Dir
       Loop
          K3 = d3.keys
   
    Set Apre = Appt.Presentations.Add
    Set cuslayout = Apre.SlideMaster.CustomLayouts(7)
   
    For i = 1 To UBound(arr)
        Appt.ActivePresentation.Slides.AddSlide i, cuslayout
    Next
         
         w = Apre.PageSetup.SlideWidth
         h = Apre.PageSetup.SlideHeight
        
    For j = 1 To UBound(arr)
           With Apre.Slides(j).Shapes.AddTextbox(1, Left:=60, Top:=60, Width:=w - 120, Height:=h - 120)
               With .Fill
                    .ForeColor.RGB = RGB(Int(Rnd * 255), Int(Rnd * 255), Int(Rnd * 255))
                    .BackColor.RGB = RGB(Int(Rnd * 255), Int(Rnd * 255), Int(Rnd * 255))
               End With
               With .TextFrame.TextRange
                    .Text = arr(j)
                    With .Font
                         .Bold = True
                         .NameFarEast = Choose(j, "宋体", "黑体", "方正姚体", "方正启体简体", "方正魏碑简体", "华文行楷", "华文仿宋", "华文隶书", "华文中宋", "楷体", "全新硬笔楷书简", "迷你简黄草", "方正康体简体")
                         .Size = 28
                         .Color.RGB = vbBlack
                    End With
               End With
            End With
     Next
     Randomize
     背景音乐 = k1(Int(Rnd * (UBound(k1) + 1)))
     系统音效 = K2(Int(Rnd * (UBound(K2) + 1)))
     自备音效 = K3(Int(Rnd * (UBound(K3) + 1)))
     
         With Apre.Slides(1).Shapes.AddMediaObject(FileName:=背景音乐, Left:=0, Top:=Apre.PageSetup.SlideHeight + 10).AnimationSettings.PlaySettings
              .PlayOnEntry = True
              .PauseAnimation = False
              .HideWhileNotPlaying = True
              .StopAfterSlides = Apre.Slides.Count
         End With
         brr = Array(257, 3849, 3855, 2817, 3587, 3894, 2306, 3845, 2049, 1281, 3909, 1537, 1025, 770, 3857, 3867, 3898, 3878, 3865, 3910, _
              3903, 3907, 3880, 3914, 3884, 3922, 3888, 3931, 3899, 3882, 3918, 3886, 3926, 3890) '34个
         sj = Rnd * UBound(brr)
         For x = 1 To UBound(arr)
             With Apre.Slides(x).SlideShowTransition
                 .AdvanceOnClick = msoFalse
                 .EntryEffect = brr(sj)
                 .AdvanceOnTime = True
                 .AdvanceTime = 5
                 .SoundEffect.ImportFromFile IIf(x Mod 2 = 1, 系统音效, 自备音效)
             End With
         Next
     
      
      Set d1 = Nothing
      Set d2 = Nothing
      Set d3 = Nothing
      Erase arr
      Erase brr
           
      Apre.SaveAs Doc.Path & "\文本.pptx"
      If MsgBox("Word To Ppt is ovver," & "Do want to continue?", vbYesNo, "Warning and Notice") = vbYes Then
         Apre.SlideShowSettings.Run
         Apre.Close: Appt.Quit
      Else
         Apre.Close: Appt.Quit
         Set Appt = Nothing
         Set Apre = Nothing
         Set cuslayout = Nothing
      End If
      Doc.Close savechanges:=wdDoNotSaveChanges
      Set Doc = Nothing
      Word.Application.Quit
End Sub