加载中…
个人资料
  • 博客等级:
  • 博客积分:
  • 博客访问:
  • 关注人气:
  • 获赠金笔:0支
  • 赠出金笔:0支
  • 荣誉徽章:
正文 字体大小:

【原创】怎样把PPT拆散成单页

(2016-10-11 09:31:18)
标签:

杂谈

分类: PPT
有时我们需要把一个PPT拆散成单页,即,把每一张幻灯片另存为一个单独的演示文稿。

Office Professional Plus 2010/2013/2016包含的PowerPoint的“发布”功能可以做到,然而对于其他版本来说,此功能不可用。

难道我们就只能一页一页地手工保存吗?当然不用,因为可以通过VBA编程解决。下面是操作步骤:

  1. 用PowerPoint打开一个演示文稿,确保只有这一个PowerPoint窗口在运行。按Alt+F11快捷键,弹出“Microsoft Visual Basic for Application”窗口,即VBA窗口。
    http://s5/middle/001IczhTzy75wQVX87Gb4&690
  2. 点击“插入”→“模块”,此时在左侧“工程 - VBAProject”窗口中出现一个“模块1”,在右侧灰色区域出现一个代码窗口。
    http://s13/middle/001IczhTzy75wQVZdyA3c&690
  3. 将以下代码复制粘贴到代码窗口中,然后按F5快捷键运行代码,即可。

    Sub SaveEachSlideAsASeparatePresentation()

            '获取当前演示文稿有多少张幻灯片
            Dim lng_SldCnt As Long
            lng_SldCnt = ActivePresentation.Slides.Count

            '获取当前演示文稿的路径
            Dim str_CurPath As String
            str_CurPath = ActivePresentation.Path

            '获取当前演示文稿的路径及完整文件名
            Dim str_CurFN As String
            str_CurFN = ActivePresentation.FullName

            '在当前演示文稿所在位置创建保存文件夹
            Dim str_StorDir As String
            str_StorDir = str_CurFN & ".split"
            If Dir(str_StorDir, vbDirectory) <> "" Then
                '用FSO.deletefolder删除同名文件夹,其实也可以用Shell调用CMD调用RD命令删除,但是VBA的Shell没有Wait和TimeOut参数,所以。。。
                CreateObject("Scripting.FileSystemObject").deletefolder str_StorDir
                '用FSO.createfolder创建同名文件夹,如果用VBA.MkDir,可能会因为还没删除完旧的文件夹就创建新的同名文件夹而导致出错
                CreateObject("Scripting.FileSystemObject").createfolder str_StorDir
            Else
                VBA.MkDir str_StorDir
            End If


            '用一个For...Next循环,在第i轮循环时,删除临时演示文稿中第i张幻灯片前后的所有幻灯片,并将临时演示文稿另存为(用SaveCopyAs方法,免得影响临时演示文稿)
            Dim i As Long, j As Long, n As Long '循环的计数器
            Dim str_StorName_Sepr As String 'Storage name of every separate slide
            Dim arrSld() '用于保存幻灯片索引的数组,可以成组删除幻灯片
            Dim sIndex As Long '数组的计数器
            n = lng_SldCnt
            Dim str_StorNameTemp As String 'storage name of the temporal presentation 本变量存储临时演示文稿的文件名
            Dim str_SLID As String '这个变量存储的是“幻灯片i”,其中i为正整数
            For i = 1 To n

                '将当前演示文稿另存到保存文件夹,充当临时演示文稿,文件名形如“幻灯片i.PPTX”,注意用SaveCopyAs方法
                str_SLID = "幻灯片" & i
                str_StorNameTemp = str_StorDir & "" & str_SLID
                ActivePresentation.SaveCopyAs str_StorNameTemp, ppSaveAsDefault

                '用两组IF判断语句,确定临时演示文稿的扩展名,并将其完整路径和完整文件名写入变量str_StorNameTemp
                If Right(Dir(str_StorNameTemp & ".*", vbNormal), 3) = "ppt" Then str_StorNameTemp = str_StorNameTemp & ".ppt"
                If Right(Dir(str_StorNameTemp & ".*", vbNormal), 3) = "ptx" Then str_StorNameTemp = str_StorNameTemp & ".pptx"
                Presentations.Open str_StorNameTemp, msoFalse, msoFalse, msoTrue '打开临时演示文稿,令窗口可见,因为我没有设计窗体也没有设计滚动条

                '定义变量CurSlds为幻灯片集合(Slides)对象变量
                Dim CurSlds As Slides
                Set CurSlds = Presentations(str_SLID).Slides

                '分类讨论:在i=1,i=n,1
                Select Case i
                    'i=1时,把第2到第n张幻灯片的编号依次写入动态数组arrSld,后者是数列,通项公式是arrSld(m)=m+1,m<=n-1
                    Case 1
                        For j = 2 To n
                            sIndex = sIndex + 1
                            ReDim Preserve arrSld(1 To sIndex)
                            arrSld(sIndex) = j
                        Next j
                    'i=n时,把第2到第n张幻灯片的编号依次写入动态数组arrSld,后者是数列,通项公式是arrSld(m)=m,m<=n-1
                    Case n
                        For j = 1 To n - 1
                            sIndex = sIndex + 1
                            ReDim Preserve arrSld(1 To sIndex)
                            arrSld(sIndex) = j
                        Next j
                    '1
    <=i-1;arrSld(m)=m+1,m>=i
                    Case Else
                        For j = 1 To i - 1
                            sIndex = sIndex + 1
                            ReDim Preserve arrSld(1 To sIndex)
                            arrSld(sIndex) = j
                        Next j
                        For j = i + 1 To n
                            sIndex = sIndex + 1
                            ReDim Preserve arrSld(1 To sIndex)
                            arrSld(sIndex) = j
                        Next j
                End Select
                CurSlds.Range(arrSld).Delete '把编号写入动态数组arrSld的所有幻灯片都删掉


                '重置数组及其计数器
                sIndex = 0
                Erase arrSld()


                '把临时演示文稿(此时仅剩原演示文稿的第i张幻灯片)保存成文件名形如“幻灯片i.pptx”的演示文稿,然后关闭
                Presentations(str_SLID).Save
                Presentations(str_SLID).Close
            Next i

            '调用资源管理器打开保存文件夹
            Dim str_SCL As String 'SCL = shell command line
            str_SCL = "Explorer.exe" & " " & str_StorDir
            Shell str_SCL, vbNormalFocus

        End Sub

  4. 要退出,只需直接关闭PowerPoint窗口即可,无需保存代码。


0

阅读 收藏 喜欢 打印举报/Report
  

新浪BLOG意见反馈留言板 欢迎批评指正

新浪简介 | About Sina | 广告服务 | 联系我们 | 招聘信息 | 网站律师 | SINA English | 产品答疑

新浪公司 版权所有