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
VBScript 批量合并PPT
最新推荐文章于 2023-06-12 16:43:22 发布