PowerPoint VBA Hangs Opening Corrupt File

Question

I have written a routine in PowerPoint VBA to search all pptx files in a selected folder and its subfolders to tally how many slides use each CustomLayout. It is actually working correctly except when it finds a pptx that, if I open it normally, gives an alert: "PowerPoint found a problem with content in (filename). If you trust the source of this presentation, click Repair. Repair or Cancel?" I don't know why so many files on my hard disk are having this problem (so far about 5 of 100 files). But the real question is: Shouldn't my VBA be able to skip over files with errors instead of giving "Run-time error '-2147467259 (800004005)': Method 'Open" of object 'Presentations' failed"?

I have been using Debug.Print and printing the results to a file, so overall it's working fine until it gets to a bad file. At first I was afraid my code might be causing the corruption, so I tried manually opening files until I got the error before my code got to it. I have also been googling this for hours and you will see in the code below that I tried several ways to skip over this error without joy.

It's the "Set ppt =" that the error message takes me to. There's a lot more code before this, but this is the troublesome part.

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

Even the following 4-line macro will generate the same problem:

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

I should probably mention that, in Settings, I have Error Trapping set to "Break on Unhandled Errors" (not on All Errors).

Any suggestions?

Answer 1

Assuming you just want to continue on without stopping, I think you could probably do this... The only drawback is if there was anything else related to opening file it would just skip it, though it would get logged in your debug window.

For Each varFilename In colFiles
    i = i + 1
  
    On Error Resume Next 'continues on without stopping
    Set ppt = Presentations.Open(varFilename, ReadOnly:=msoTrue, Untitled:=msoTrue, WithWindow:=msoFalse)
    On Error GoTo 0 'prevents further error skipping
    
    
    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
        'ensures blank variable on next loop
        Set ppt = Nothing
            
    Else
        Debug.Print "Issue With " & varFilename 'log the issue
        
    End If

Next varFilename