Merging last slides from multiple PowerPoint Presentations

Question

I am trying to combine the last slide from many PowerPoints and want to avoid having to open each item and copy and paste them into a grouped deck.

Ex: I have DeckA (with slides 1, 2 and 3), DeckB (with slides 1, and 2) and DeckC (with slides 1, 2, 3 and 4) and I want DeckA slide 3, DeckB slide 2 and DeckC slide 4 all in one combined deck.

I found the similar question here and I tried using Slides.Count in the FillRangeArray to only get the last slide but that doesn't seem to have done anything.

Option Explicit

Sub WriteLine ( strLine )
    WScript.Stdout.WriteLine strLine
End Sub

Sub WriteError ( strLine )
    WScript.Stderr.WriteLine strLine
End Sub

Dim inputFile1, inputFile2, inputFile3
Dim outputFile, outputFileFinal
Dim objPPT, objFso, objPresentation, objFileSys

inputFile1 = "C:\Users\UserName\Downloads\PPT #1.pptx"
inputFile2 = "C:\Users\UserName\Downloads\PPT #2.pptx"
inputFile3 = "C:\Users\UserName\Downloads\PPT #3.pptx"
outputFile = "C:\Users\UserName\Downloads\output.pptx"
outputFileFinal = "C:\Users\UserName\Downloads\outputFINAL.pptx"

Set objFso = CreateObject("Scripting.FileSystemObject")

If Not objFso.FileExists( inputFile1 ) Then
    WriteError "Unable to find your input file " & inputFile1
    WScript.Quit 1
End If
If Not objFso.FileExists( inputFile2 ) Then
    WriteError "Unable to find your input file " & inputFile2
    WScript.Quit 1
End If
If Not objFso.FileExists( inputFile3 ) Then
    WriteError "Unable to find your input file " & inputFile3
    WScript.Quit 1
End If

WriteLine "Input File 1 :  " & inputFile1
WriteLine "Input File 2 :  " & inputFile2
WriteLine "Input File 3 :  " & inputFile3
WriteLine "Output File: " & outputFileFinal

Set objPPT = CreateObject( "PowerPoint.Application" )

' Open presentation with window hidden
Set objPresentation = objPPT.Presentations.Open(inputFile1, True, False, False)

mergeAndKeepSourceFormatting objPresentation, inputFile2
WriteLine "Saving File: " & outputFile
objPresentation.SaveAs outputFile

objPresentation.Close
ObjPPT.Quit

    Set objPPT = CreateObject( "PowerPoint.Application" )

    ' Open presentation with window hidden
    Set objPresentation = objPPT.Presentations.Open(outputFile, True, False, False)

    mergeAndKeepSourceFormatting objPresentation, inputFile3
    WriteLine "Saving File: " & outputFileFinal
    objPresentation.SaveAs outputFileFinal

    objPresentation.Close
    ObjPPT.Quit
    
Set objFileSys = CreateObject("Scripting.FileSystemObject")
objFileSys.DeleteFile outputFile

'
' Add the file to the loaded presentation
'
Sub mergeAndKeepSourceFormatting(ByRef objPresentation, ByVal newPptxFile)
    WriteLine "Merging file: " & newPptxFile
    Dim newSlides
    Dim oldSlides
    oldSlides = objPresentation.Slides.Count
    newSlides = objPresentation.Slides.InsertFromFile( newPptxFile, objPresentation.Slides.Count)
    objPresentation.Slides.Range(FillRangeArray(oldSlides + 1, oldSlides + newSlides)).ApplyTemplate newPptxFile

End Sub


Function FillRangeArray(n1, n2) 
    Dim myArr()
    Redim myArr(n2 - n1)
    Dim i
    For i = 0 to (n2 - n1)
        myArr(i) = n1 + i
    Next
    FillRangeArray = myArr
End Function

I assume too there's probably an easier way to just loop through the input file variables starting on line 16 vs creating a whole new code block and output set of files that would get deleted with each new slide. I feel like I am over complicating it and I just am not looking in the right place.

Merging last slides from multiple PowerPoint Presentations

0 Answers0