VBScript 批量合并PPT

Option Explicit
Public FileNames As Variant
Public SaveName As Variant
Public pptApp As Object

Sub GetFiles()
    FileNames = Application.GetOpenFilename _
    (FileFilter:="演示文稿(*.ppt),*.ppt", FilterIndex:=1, _
    MultiSelect:=True, Title:="打开需要合并的文件")
End Sub

Sub SaveFileAs()
    SaveName = Application.GetSaveAsFilename(InitialFileName:="文稿合并结果", _
    FileFilter:="演示文稿(*.ppt),*.ppt", FilterIndex:=1, _
    Title:="保存文稿合并结果")
End Sub
Sub Merge()
    Dim Pre As Object
    Dim i As Double
    Dim n As Double
    Err.Clear
    On Error Resume Next
    Set pptApp = CreateObject("PowerPoint.application")
    pptApp.DisplayAlerts = False
    On Error GoTo 0
    If Err.Number <> 0 Then
        Beep
        MsgBox "出错，系统没有安装 MS PowerPoint", vbOKOnly, "合并演示文稿"
        pptApp.Quit
        Application.Quit
    End If
    Err.Clear
    On Error Resume Next
    
    Set Pre = pptApp.Presentations.Add
    For i = LBound(FileNames) To UBound(FileNames)
        DoEvents
        n = Pre.Slides.Count
        Pre.Slides.InsertFromFile Index:=n, FileName:=FileNames(i)
        UserForm1.Label.Caption = "正在合并演示文稿…" & i & "个已完成！"
    Next
    On Error GoTo 0
    If Err.Number <> 0 Then
        Beep
        MsgBox "出现未知错误！退出？", vbOKOnly, "合并演示文稿"
        pptApp.Quit
        Application.Quit
    End If
    Pre.SaveAs (SaveName)
    pptApp.DisplayAlerts = True
    pptApp.Quit
    UserForm1.Label.Caption = "演示文稿合并完成！"
    UserForm1.cmdQuit.Caption = "确定(Q)"
    
End Sub