PowerPoint VBA打开损坏PPTX报错，如何自动跳过错误文件？

问题背景 #

我编写了一段PowerPoint VBA例程，用于遍历选中文件夹及其子文件夹中的所有PPTX文件，统计每个CustomLayout的幻灯片使用次数。例程正常运行良好，但遇到损坏的PPTX文件时（手动打开会弹出提示："PowerPoint found a problem with content in (filename). If you trust the source of this presentation, click Repair. Repair or Cancel?"），会触发运行时错误-2147467259 (800004005): Method 'Open' of object 'Presentations' failed，无法跳过错误文件。

我已尝试添加错误处理逻辑但无效，错误发生在Set ppt = Presentations.Open(...)代码行，即使简化测试宏也会出现相同问题：

Sub TestOpeningABadFile()
Dim ppt As Presentation
Set ppt = Presentations.Open("CorruptFile.pptx")
End Sub

我的错误捕获设置为"Break on Unhandled Errors"而非"Break on All Errors"，现寻求解决方案。原问题代码片段如下：

For Each varFilename In colFiles
    i = i + 1
    On Error GoTo ErrorOpeningPresentation
    Set ppt = Presentations.Open(varFilename, ReadOnly:=msoTrue, Untitled:=msoTrue, WithWindow:=msoFalse)
    If Err.Number <> 0 Then GoTo ErrorOpeningPresentation
    If Not ppt Is Nothing Then 'See if this skips files that PP can't read
        Debug.Print "File " & i & " of " & colFiles.Count & ", " & ppt.Slides.Count & " slides in " & varFilename
        For Each sld In ppt.Slides
            Print #1, i & "; " & varFilename & "; Slide " & sld.SlideIndex & "; Layout " & sld.CustomLayout.Index & "; " & sld.CustomLayout.Name
        Next sld
        Presentations.Item(2).Close
        Set ppt = Nothing
        'Every 10 files pause 5 seconds to see if this helps to stop it from hanging
        If i Mod 10 = 0 Then
            tStart = Timer: While Timer < tStart + 5: DoEvents: Wend
        End If
    End If
ErrorOpeningPresentation:
    On Error GoTo 0

Next varFilename

解决方案 #

方法1：修复错误处理逻辑，禁用打开时的警告弹窗 #

PowerPoint打开损坏文件时弹出的修复提示框会阻塞VBA执行，导致错误捕获失效。正确的做法是先禁用所有警告，再尝试打开文件，最后恢复原有设置：

For Each varFilename In colFiles
    i = i + 1
    Dim originalAlertSetting As MsoAlertLevel
    ' 保存原警告设置并禁用所有弹窗
    originalAlertSetting = Application.DisplayAlerts
    Application.DisplayAlerts = msoAlertsNone
    
    ' 临时启用错误继续执行，捕获打开失败的情况
    On Error Resume Next
    Set ppt = Presentations.Open(varFilename, ReadOnly:=msoTrue, Untitled:=msoTrue, WithWindow:=msoFalse)
    On Error GoTo 0 ' 恢复默认错误处理
    
    If Not ppt Is Nothing Then
        Debug.Print "File " & i & " of " & colFiles.Count & ", " & ppt.Slides.Count & " slides in " & varFilename
        For Each sld In ppt.Slides
            Print #1, i & "; " & varFilename & "; Slide " & sld.SlideIndex & "; Layout " & sld.CustomLayout.Index & "; " & sld.CustomLayout.Name
        Next sld
        ' 直接关闭当前演示文稿，避免用索引引用出错
        ppt.Close SaveChanges:=msoFalse
        Set ppt = Nothing
        
        ' 每处理10个文件暂停5秒
        If i Mod 10 = 0 Then
            tStart = Timer: While Timer < tStart + 5: DoEvents: Wend
        End If
    Else
        ' 记录无法打开的文件路径
        Debug.Print "无法打开损坏文件: " & varFilename
    End If
    
    ' 恢复原警告设置
    Application.DisplayAlerts = originalAlertSetting
Next varFilename

方法2：提前检查PPTX文件完整性（可选） #

如果希望在尝试打开前就过滤损坏文件，可以利用PPTX是压缩包的特性，提前验证文件是否有效：

Function IsValidPPTX(filePath As String) As Boolean
    On Error Resume Next
    Dim fso As Object, zipNamespace As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    ' 先检查文件存在且后缀为pptx
    If Not fso.FileExists(filePath) Or LCase(fso.GetExtensionName(filePath)) <> "pptx" Then
        IsValidPPTX = False
        Exit Function
    End If
    
    ' 尝试访问压缩包内容，判断文件是否损坏
    Set zipNamespace = CreateObject("Shell.Application").Namespace(fso.GetAbsolutePathName(filePath))
    IsValidPPTX = Not zipNamespace Is Nothing
    On Error GoTo 0
End Function

使用时在循环中先调用该函数：

For Each varFilename In colFiles
    If IsValidPPTX(varFilename) Then
        ' 执行原有的打开和统计逻辑
    Else
        Debug.Print "无效或损坏的PPTX文件: " & varFilename
    End If
Next

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