如何将一个PPT两页两页拆分成多个PPT
各位老师好，我是PPT学习论坛的新人。我个人是教育工作者，一直都在跟PPT打交道。最近开始接触VBA，感觉对自己的工作非常有帮助。我利用VBA，用Excel表格生成了一个英语短语的PPT。这个PPT上每两页是针对一个短语的解释。现在想把这个PPT，每两页保存为一个新的PPT，但是却摸不到方法了。
单页保存PPT可以用export解决，要保存多页的话，想请教一下各位老师，应当怎样操作才好？先行谢谢了！
另外，想向各位老师求教，目前见到的比较多的是关于excel的VBA教程，单纯讲PPT的却不多。请问哪里有比较好的学习资料，收费的也可以。 我在以下链接中找到一种解决办法，但是效率很低。如果是一个几兆的PPT，这样拆分下来要费好长的时间。不知道是否有更好更有效率的方法？http://www.pptfaq.com/FAQ01086_Break_a_presentation_up_into_several_smaller_presentations.htm
链接中的方法，是每次把整个PPT都另存一下，然后删掉多与的slides。代码如下：
[*]Sub SplitFile()
[*]
[*] Dim lSlidesPerFile As Long
[*] Dim lTotalSlides As Long
[*] Dim oSourcePres As Presentation
[*] Dim otargetPres As Presentation
[*] Dim sFolder As String
[*] Dim sExt As String
[*] Dim sBaseName As String
[*] Dim lCounter As Long
[*] Dim lPresentationsCount As Long ' how many will we split it into
[*] Dim x As Long
[*] Dim lWindowStart As Long
[*] Dim lWindowEnd As Long
[*] Dim sSplitPresName As String
[*]
[*] On Error GoTo ErrorHandler
[*]
[*] Set oSourcePres = ActivePresentation
[*] If Not oSourcePres.Saved Then
[*] MsgBox "Please save your presentation then try again"
[*] Exit Sub
[*] End If
[*]
[*] lSlidesPerFile = CLng(InputBox("How many slides per file?", "Split Presentation"))
[*] lTotalSlides = oSourcePres.Slides.Count
[*] sFolder = ActivePresentation.Path & ""
[*] sExt = Mid$(ActivePresentation.Name, InStr(ActivePresentation.Name, ".") + 1)
[*] sBaseName = Mid$(ActivePresentation.Name, 1, InStr(ActivePresentation.Name, ".") - 1)
[*]
[*] If (lTotalSlides / lSlidesPerFile) - (lTotalSlideslSlidesPerFile) > 0 Then
[*] lPresentationsCount = lTotalSlideslSlidesPerFile + 1
[*] Else
[*] lPresentationsCount = lTotalSlideslSlidesPerFile
[*] End If
[*]
[*] If Not lTotalSlides > lSlidesPerFile Then
[*] MsgBox "There are fewer than " & CStr(lSlidesPerFile) & " slides in this presentation."
[*] Exit Sub
[*] End If
[*]
[*] For lCounter = 1 To lPresentationsCount
[*]
[*] ' which slides will we leave in the presentation?
[*] lWindowEnd = lSlidesPerFile * lCounter
[*] If lWindowEnd > oSourcePres.Slides.Count Then
[*] ' odd number of leftover slides in last presentation
[*] lWindowEnd = oSourcePres.Slides.Count
[*] lWindowStart = ((oSourcePres.Slides.CountlSlidesPerFile) * lSlidesPerFile) + 1
[*] Else
[*] lWindowStart = lWindowEnd - lSlidesPerFile + 1
[*] End If
[*]
[*] ' Make a copy of the presentation and open it
[*] sSplitPresName = sFolder & sBaseName & _
[*] "_" & CStr(lWindowStart) & "-" & CStr(lWindowEnd) & "." & sExt
[*] oSourcePres.SaveCopyAs sSplitPresName, ppSaveAsDefault
[*] Set otargetPres = Presentations.Open(sSplitPresName, , , True)
[*]
[*] With otargetPres
[*] For x = .Slides.Count To lWindowEnd + 1 Step -1
[*] .Slides(x).Delete
[*] Next
[*] For x = lWindowStart - 1 To 1 Step -1
[*] .Slides(x).Delete
[*] Next
[*] .Save
[*] .Close
[*] End With
[*]
[*] Next ' lpresentationscount
[*]
[*]NormalExit:
[*] Exit Sub
[*]ErrorHandler:
[*] MsgBox "Error encountered"
[*] Resume NormalExitEnd Sub
复制代码 自己鼓捣出来第二种方法，虽然写得笨了点，但是还算是好用：
[*]Sub createNewPres()
[*]
[*]Dim oldPres As Presentation, newPres As Presentation, fPath As String, fName As String
[*]Set oldPres = ActivePresentation
[*]Set newPres = Presentations.Add(True)
[*]fPath = oldPres.Path & ""
[*]For i = 1 To oldPres.Slides.Count Step 2
[*] fName = oldPres.Slides(i).Shapes("Title 1").TextFrame.TextRange.Text
[*]
[*] oldPres.Slides(i).Copy
[*] newPres.Slides.Paste
[*] newPres.Slides(1).Design = oldPres.Slides(i).Design
[*] newPres.Slides(1).ColorScheme = oldPres.Slides(i).ColorScheme
[*] newPres.Slides(1).FollowMasterBackground = oldPres.Slides(i).FollowMasterBackground
[*]
[*] oldPres.Slides(i + 1).Copy
[*] newPres.Slides.Paste
[*] newPres.Slides(2).Design = oldPres.Slides(i + 1).Design
[*] newPres.Slides(2).ColorScheme = oldPres.Slides(i + 1).ColorScheme
[*] newPres.Slides(2).FollowMasterBackground = oldPres.Slides(i + 1).FollowMasterBackground
[*]
[*] newPres.SaveAs fPath & fName & ".ppt"
[*] newPres.Close
[*] Set newPres = Presentations.Add(True)
[*]Next i
[*]End Sub
复制代码
页:
[1]