Error trying to open ppt file & a couple of other doubts (powerpoint)

Question

I'm trying to write a sub that saves the individual slides of the Powerpoint files in a user select directory and saves them in another user selected directory.

The source and target dialog boxes seem to be working ok but I get a 'Method' Open of objects 'Presentation'. I can't solve it.

Also, if I wanted to process both ppt and pptx time files in the loop, what changes should I make.

An finally, what needs to be done to make it recursice wo it processes the selected folder and all subfolder.

I know It's a lot buy thanks in advance.

Juan

Here's the code

Sub ExportPPTSlidesToSingles()
''Application.DisplayAlerts = False

Dim oPptApp As PowerPoint.Application

'Initial directory path.
Dim IntialPath As String

Dim SourceDialogBox As FileDialog
Dim TargetDialogBox As FileDialog
Dim SourceFolder As String
Dim TargetFolder As String
Dim SourceFile As Presentation
Dim TempPresentation As Presentation
Dim PresentationToProcess As String
Dim counter As Long

Dim OpenPresentation As Presentation
Dim TargetFileName As String



Set oPptApp = CreateObject("PowerPoint.Application")
Set SourceDialogBox = oPptApp.FileDialog(msoFileDialogFolderPicker)
Set TargetDialogBox = oPptApp.FileDialog(msoFileDialogFolderPicker)

ActiveWindow.ViewType = ppViewNormal
IntialPath = "D:\_ infographics\temp\"

'Select source data folder
MsgBox ("Select a SOURCE folder where input Powerpoint files are located.")
Set SourceDialogBox = Application.FileDialog(msoFileDialogFolderPicker)

If SourceDialogBox.Show = -1 Then
SourceFolder = SourceDialogBox.SelectedItems(1)
End If

'Select target data folder
MsgBox ("Select a TARGET folder - where the individual files will be saved.")
If TargetDialogBox.Show = -1 Then
TargetFolder = TargetDialogBox.SelectedItems(1)
End If

    If MsgBox("Depending on the number of visible slides to export and the size " & _
    "of your presentation, this might take some time." & vbCrLf & vbCrLf & "Continue?", _
    vbYesNo + vbQuestion, _
    "Export " & counter & " Visible Slides to Presentations") = vbNo Then Exit Sub
  
'Loop through only pptx files in source folder
PresentationToProcess = Dir(SourceFolder & "\*.ppt*")

MsgBox PresentationToProcess

While PresentationToProcess <> ""
    
    ' Open source files
    Set OpenPresentation = Presentations.Open(PresentationToProcess)
      
    On Error GoTo errorhandler

    ' Make a temoprary copy
    TempPresentation.SaveCopyAs (Environ("TEMP") & "\temppres.pptx")

    On Error Resume Next
    Set TempPresentation = Presentations.Open(FileName:=Environ("TEMP") & "\temppres.pptx", WithWindow:=False)
    
    
    ' Loop through slides
    For counter = OpenPresentation.Slides.count To 1 Step -1
        OpenPresentation.Slides(counter).Copy
        TempPresentation.Slides.Paste
       
        ' Create a unique filename and save a copy of each slide
        TargetFileName = Left(ActivePresentation.Name, InStrRev(ActivePresentation.Name, ".") - 1) & " [" & counter & "].pptx"
        Call TempPresentation.SaveAs(FileName:=Environ("USERPROFILE") & "\Desktop\slides\" & TargetFileName & counter & ".pptx", EmbedTrueTypeFonts:=False)
        TempPresentation.Slides(1).Delete
    Next counter
   TempPresentation.Close
  
    OpenPresentation.Close
    OpenPresentation = Dir
    Wend


'Close the ppt
oPptApp.Presentations.Application.Quit

  On Error GoTo 0
 
  Exit Sub
 
errorhandler:
  Debug.Print Err, Err.Description
  Resume Next
End Sub

Answer 1

So you were encountering this error because the code does not use the full path of the source file it attempts to load. This is a feature of dir - it only returns the filename and not the path of the file. It's easily solved, just change the relevant line in the code to:

Set OpenPresentation = Presentations.Open(SourceFolder & "\" & PresentationToProcess)

Looking at the rest of your code, you'll encounter one more problem - you later try and assign the next filename to the object OpenPresentation. Combined with the earlier On Error statement, this will endlessly loop your code. This should be changed to:

PresentationToProcess = Dir

Full revised code below. Hope that helps - let me know if you have any issues with it.

Sub ExportPPTSlidesToSingles()
''Application.DisplayAlerts = False

Dim oPptApp As PowerPoint.Application

'Initial directory path.
Dim IntialPath As String

Dim SourceDialogBox As FileDialog
Dim TargetDialogBox As FileDialog
Dim SourceFolder As String
Dim TargetFolder As String
Dim SourceFile As Presentation
Dim TempPresentation As Presentation
Dim PresentationToProcess As String
Dim counter As Long

Dim OpenPresentation As Presentation
Dim TargetFileName As String



Set oPptApp = CreateObject("PowerPoint.Application")
Set SourceDialogBox = oPptApp.FileDialog(msoFileDialogFolderPicker)
Set TargetDialogBox = oPptApp.FileDialog(msoFileDialogFolderPicker)

ActiveWindow.ViewType = ppViewNormal
IntialPath = "D:\_ infographics\temp\"

'Select source data folder
MsgBox ("Select a SOURCE folder where input Powerpoint files are located.")
Set SourceDialogBox = Application.FileDialog(msoFileDialogFolderPicker)

If SourceDialogBox.Show = -1 Then
SourceFolder = SourceDialogBox.SelectedItems(1)
End If

'Select target data folder
MsgBox ("Select a TARGET folder - where the individual files will be saved.")
If TargetDialogBox.Show = -1 Then
TargetFolder = TargetDialogBox.SelectedItems(1)
End If

    If MsgBox("Depending on the number of visible slides to export and the size " & _
    "of your presentation, this might take some time." & vbCrLf & vbCrLf & "Continue?", _
    vbYesNo + vbQuestion, _
    "Export " & counter & " Visible Slides to Presentations") = vbNo Then Exit Sub
  
'Loop through only pptx files in source folder
PresentationToProcess = Dir(SourceFolder & "\*.ppt*")

MsgBox PresentationToProcess

While PresentationToProcess <> ""
    
    ' Open source files
    Set OpenPresentation = Presentations.Open(SourceFolder & "\" & PresentationToProcess)
      
    On Error GoTo errorhandler

    ' Make a temoprary copy
    TempPresentation.SaveCopyAs (Environ("TEMP") & "\temppres.pptx")

    On Error Resume Next
    Set TempPresentation = Presentations.Open(FileName:=Environ("TEMP") & "\temppres.pptx", WithWindow:=False)
    
    
    ' Loop through slides
    For counter = OpenPresentation.Slides.count To 1 Step -1
        OpenPresentation.Slides(counter).Copy
        TempPresentation.Slides.Paste
       
        ' Create a unique filename and save a copy of each slide
        TargetFileName = Left(ActivePresentation.Name, InStrRev(ActivePresentation.Name, ".") - 1) & " [" & counter & "].pptx"
        Call TempPresentation.SaveAs(FileName:=Environ("USERPROFILE") & "\Desktop\slides\" & TargetFileName & counter & ".pptx", EmbedTrueTypeFonts:=False)
        TempPresentation.Slides(1).Delete
    Next counter
   TempPresentation.Close
  
    OpenPresentation.Close
    PresentationToProcess = Dir
    Wend


'Close the ppt
oPptApp.Presentations.Application.Quit

  On Error GoTo 0
 
  Exit Sub
 
errorhandler:
  Debug.Print Err, Err.Description
  Resume Next
End Sub