Open method not working to open ppts from a ppt

Question

I'm having a bit of trouble here. My code stops with a Run-time error -2147467259 (80004005) Mehod 'Open' of object 'Presentations: failed.

This code presents a warning, prompts for source and target folder and loops through all files in the source folder, opening each file and exporting each slide as an individual file, and again until the last file in the folder.

I put a couple of msgboxes to see if it was a problem with the names, re-wrote the open file segment based on some code from MVP Andy Pope, yet nothing.

Any help is deeply appreciated.

Sub ExportIndividualSlides()
    ''Application.DisplayAlerts = False
    
    Dim ObjPPAPP As New PowerPoint.Application
    Dim objPPPres As PowerPoint.Presentation
    Dim objPPSlide As PowerPoint.Slide
    
    'Initial directory path.
    Dim SourceFolder As String
    Dim TargetFolder As String
    SourceFolder = "c:\source"
    TargetFolder = "c:\target"
    
    Dim Slide As Long
    Dim SourcePresentation As Presentation
    Dim SourcePresentationName As String
    Dim TargetFileName As String
    Dim SourceNamePath
    
    Debug.Print "-- Start --------------------------------"
    
    ActiveWindow.ViewType = ppViewNormal
    
    'Loop through ppt* files only in source folder
       
        SourcePresentationName = Dir(SourceFolder & "\*.ppt*")
            
        MsgBox "SPN:" & SourcePresentationName
            
        While (SourcePresentationName <> "")
            
            SourceNamePath = SourceFolder & "\" & SourcePresentationName
            Debug.Print "   SourceNamePath"
            
            MsgBox SourceNamePath
            
            Set ObjPPAPP = New PowerPoint.Application
            ObjPPAPP.Visible = True
            Set objPPPres = ObjPPAPP.Presentations.Open(SourceNamePath)
            
        '    On Error GoTo errorhandler
            
            ' Open source files
            Set SourcePresentation = Presentations.Open(FileName:=SourcePresentationName, WithWindow:=False)
            Debug.Print "   SourcePresentation: " & SourcePresentation.Name
        
            ' Loop through slides
            For Slide = 1 To SourcePresentation.Slides.Count
            Debug.Print "   Slide: " & Slide
               
                ' Create a unique filename and save a copy of each slide
                TargetFileName = Left(SourcePresentation.Name, InStrRev(SourcePresentation.Name, ".") - 1) & " [" & Slide & "].pptx"
                TargetNamePath = TargetFolder & "\" & TargetFileName
                Debug.Print "   TargetNamePath: " & TargetNamePath
                SourcePresentation.Slides(Slide).Export TargetNamePath, "PPTX"
            
            Next Slide
            objPPPres = Nothing
            SourcePresentation.Close
            SourcePresentationName = Dir
        Wend
    
    
      On Error GoTo 0
      Exit Sub
     
errorhandler:
      Debug.Print Err, Err.Description
      Resume Next
    
End Sub

Answer 1

This worked for me:

Sub ExportIndividualSlides()
    'use const for fixed values
    Const SOURCE_FOLDER As String = "c:\source\" 'include terminal \
    Const TARGET_FOLDER As String = "c:\target\"
    
    Dim objPres As PowerPoint.Presentation
    Dim Slide As Long
    Dim SourcePresentationName As String
    Dim TargetFileName As String
    Dim TargetNamePath As String
    Dim SourceNamePath
    
    Debug.Print "-- Start --------------------------------"
    ActiveWindow.ViewType = ppViewNormal
    
    On Error GoTo errorhandler
    
    'Loop through ppt* files only in source folder
    SourcePresentationName = Dir(SOURCE_FOLDER & "*.ppt*")
    Do While Len(SourcePresentationName) > 0
        
        SourceNamePath = SOURCE_FOLDER & SourcePresentationName
        Debug.Print "Opening: " & SourceNamePath
        
        Set objPres = Presentations.Open(SourceNamePath)
        
        ' Loop through slides
        For Slide = 1 To objPres.Slides.Count
            
            Debug.Print "   Slide: " & Slide
            ' Create a unique filename and save a copy of each slide
            TargetFileName = Left(objPres.Name, InStrRev(objPres.Name, ".") - 1) & " [" & Slide & "].pptx"
            TargetNamePath = TARGET_FOLDER & TargetFileName
            Debug.Print "   TargetNamePath: " & TargetNamePath
            objPres.Slides(Slide).Export TargetNamePath, "PPTX"
        
        Next Slide
        
        objPres.Close
        
        SourcePresentationName = Dir() 'next file
    Loop
    
    Exit Sub
     
errorhandler:
    Debug.Print Err, Err.Description
    Resume Next
    
End Sub