如何通过PowerPoint VBA判断MP4导出完成并自动关闭文稿

我用VBA将PowerPoint演示文稿保存为MP4文件，希望在导出操作完成后关闭演示文稿，但不知道如何判断导出何时结束。

现有代码片段（待完善判断逻辑）：

ActivePresentation.SaveAs outFile, 39

Do While ????

ActivePresentation.Close

Loop

目前我用wscript.sleep延迟关闭，但这不是最优方案——不同大小的文件导出耗时差异很大，固定延迟要么浪费时间，要么可能导致导出未完成就关闭：

ActivePresentation.SaveAs outFile, pptFormat

' save as MP4 need long time, do not close too early
If StrComp(Ucase( outFormat ),"MP4") = 0 then
    wscript.sleep 1000*60
End If
' Close the active document
ActivePresentation.Close

解决方案：监控视频导出状态 #

PowerPoint的Presentation对象提供了CreateVideoStatus属性，可直接判断MP4导出的进度。SaveAs方法导出MP4本质上调用了视频创建流程，因此可以通过循环检查该属性，直到导出完成。

核心替换代码 #

把原来的固定sleep代码替换为动态状态检查：

If StrComp(UCase(outFormat), "MP4") = 0 Then
    ' 循环等待视频导出完成
    Do While objPresentation.CreateVideoStatus = ppVideoStatusCreating
        WScript.Sleep 500 ' 每0.5秒检查一次状态，避免占用过多资源
    Loop
End If

需要在代码中添加对应的状态常量（也可直接使用数值1/2）：

Const ppVideoStatusCreating = 1 ' 正在导出
Const ppVideoStatusReady = 2     ' 导出完成

修改后的完整代码 #

Option Explicit
 
'PPT2ANY "PATH_TO_INFILE\NEOHOPE.COM.IN.pptx","PATH_TO_INFILE\NEOHOPE.COM.OUT.pdf","PDF"
'PPT2ANY "PATH_TO_INFILE\NEOHOPE.COM.IN.pptx","PATH_TO_INFILE\NEOHOPE.COM.OUT.png","PNG"
PPT2ANY "D:\video\generateComplete1.pptx","D:\video\onlyVideo1","MP4"
'Call PPT2ANY(WScript.Arguments(0),WScript.Arguments(1),WScript.Arguments(2))
 
Sub PPT2ANY( inFile, outFile, outFormat)
    Dim objFSO, objPPT, objPresentation, pptFormat
 
    Const ppSaveAsAddIn                             =8
    Const ppSaveAsBMP                               =19
    Const ppSaveAsDefault                           =11
    Const ppSaveAsEMF                               =23
    Const ppSaveAsExternalConverter                 =64000
    Const ppSaveAsGIF                               =16
    Const ppSaveAsJPG                               =17
    Const ppSaveAsMetaFile                          =15
    Const ppSaveAsMP4                               =39
    Const ppSaveAsOpenDocumentPresentation          =35
    Const ppSaveAsOpenXMLAddin                      =30
    Const ppSaveAsOpenXMLPicturePresentation        =36
    Const ppSaveAsOpenXMLPresentation               =24
    Const ppSaveAsOpenXMLPresentationMacroEnabled   =25
    Const ppSaveAsOpenXMLShow                       =28
    Const ppSaveAsOpenXMLShowMacroEnabled           =29
    Const ppSaveAsOpenXMLTemplate                   =26
    Const ppSaveAsOpenXMLTemplateMacroEnabled       =27
    Const ppSaveAsOpenXMLTheme                      =31
    Const ppSaveAsPDF                               =32
    Const ppSaveAsPNG                               =18
    Const ppSaveAsPresentation                      =1
    Const ppSaveAsRTF                               =6
    Const ppSaveAsShow                              =7
    Const ppSaveAsStrictOpenXMLPresentation         =38
    Const ppSaveAsTemplate                          =5
    Const ppSaveAsTIF                               =21
    Const ppSaveAsWMV                               =37
    Const ppSaveAsXMLPresentation                   =34
    Const ppSaveAsXPS                               =33
    ' 视频导出状态常量
    Const ppVideoStatusCreating = 1
    Const ppVideoStatusReady = 2
 
    ' 创建文件系统对象
    Set objFSO = CreateObject( "Scripting.FileSystemObject" )
 
    ' 创建PowerPoint对象
    Set objPPT = CreateObject( "PowerPoint.Application" )
 
    With objPPT
        ' True: 显示PowerPoint界面; False: 后台运行
        .Visible = True
  
        ' 检查输入文件是否存在
        If Not( objFSO.FileExists( inFile ) ) Then
            WScript.Echo "FILE OPEN ERROR: 文件不存在" & vbCrLf
            ' 关闭PowerPoint
            .Quit
            Exit Sub
        End If
  
        ' 打开演示文稿
        .Presentations.Open inFile
  
        ' 获取当前活动演示文稿
        Set objPresentation = .ActivePresentation
  
        ' 匹配导出格式对应的常量
        If StrComp(UCase( outFormat ),"PDF") = 0 then
            pptFormat = ppSaveAsPDF 
        ElseIf StrComp(UCase( outFormat ),"XPS") = 0 then
            pptFormat = ppSaveAsXPS
        ElseIf StrComp(UCase( outFormat ),"BMP") = 0 then
            pptFormat= ppSaveAsBMP
        ElseIf StrComp(UCase( outFormat ),"PNG") = 0 then
            pptFormat= ppSaveAsPNG
        ElseIf StrComp(UCase( outFormat ),"JPG") = 0 then
            pptFormat= ppSaveAsJPG
        ElseIf StrComp(UCase( outFormat ),"GIF") = 0 then
            pptFormat= ppSaveAsGIF
        ElseIf StrComp(UCase( outFormat ),"XML") = 0 then
            pptFormat= ppSaveAsOpenXMLPresentation
        ElseIf StrComp(UCase( outFormat ),"RTF") = 0 then
            pptFormat= ppSaveAsRTF
        ElseIf StrComp(UCase( outFormat ),"MP4") = 0 then
            pptFormat= ppSaveAsMP4
        Else
            WScript.Echo "FILE FORMAT ERROR: 未知文件格式" & vbCrLf
            ' 关闭PowerPoint
            .Quit
            Exit Sub
        End If
 
        ' 执行导出操作
        objPresentation.SaveAs outFile, pptFormat

        ' 针对MP4格式，等待导出完成
        If StrComp(UCase(outFormat), "MP4") = 0 Then
            ' 循环等待直到视频创建完成
            Do While objPresentation.CreateVideoStatus = ppVideoStatusCreating
                WScript.Sleep 500 ' 每隔0.5秒检查一次状态
            Loop
        End If
        
        ' 关闭当前演示文稿
        objPresentation.Close
  
        ' 退出PowerPoint
        .Quit
    End With
End Sub

内容的提问来源于stack exchange，提问作者mouseMi