将PPT拆分成单页

> 该代码可以将 PPT 拆分为单页版本，如果一次性需要拆分的页数很多，想要快速拆分的话，推荐使用 PowerPoint 2013 版的[共享-发布幻灯片](https://mp.weixin.qq.com/s/T8qsqhmpPexgPXbAtJJEbA)功能，速度更快。

**代码如下：**

```vb
Sub 拆分为单页()
    
    '获取当前演示文稿有多少张幻灯片'
    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<i<n 这三种情况下，如何处理'
        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<n 时，把第 i 张幻灯片两侧所有幻灯片的编号分别依次写入动态数组 arrSld，后者是数列，通项公式是 arrsld(m)=m，m<=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
```

来源：[怎样把 PPT 拆散成单页？](https://zhuanlan.zhihu.com/p/20552409 "怎样把 PPT 拆散成单页？")