Can't get the Excel VBA to copy PPT files - vba

Question

I have the following code, I attempted to modify it so it loops through a list in excel, opens each ppt file in the list and copies that to a new ppt file. But it is getting hung up and has an error during the loop.
Sub tmp()
'Set a VBE reference to Microsoft PowerPoint Object Library
On Error GoTo ErrorHandler
Dim PPApp As PowerPoint.Application
Dim i, j As Integer
Dim pres1, new_pres As PowerPoint.Presentation
Dim oslide, s, oSld As PowerPoint.Slide
Dim oShape, oSh, oshp As PowerPoint.Shape
Dim wb As Workbook
Dim list As Worksheet
Set PPApp = CreateObject("Powerpoint.Application")
PPApp.Visible = True
Set new_pres = PPApp.Presentations.Add
Set wb = ThisWorkbook
Set list = wb.Worksheets("Powerpoint File List")
LastRow = list.Range("A" & Rows.Count).End(xlUp).Row
new_pres.PageSetup.SlideSize = ppSlideSizeOnScreen
' this is not working
For i = 1 To 1 ' LastRow
filepath = list.Range("A" & i).Value
Set pres1 = PPApp.Presentations.Open(filepath)
For j = 1 To pres1.Slides.Count
pres1.Slides.shapes(j).Copy
new_pres.Slides.Paste
new_pres.Application.CommandBars.ExecuteMso "PasteSourceFormatting")
Next j
pres1.Close
Set pres1 = Nothing
Next I
NormalExit:
Exit Sub
ErrorHandler:
Call MsgBox("Error:" & vbCrLf & Err.Number & vbCrLf & Err.Description, _
vbOKOnly, "Error inserting files")
Resume NormalExit
End Sub

Answer 1

I got it to work, it was the PasteSourceFormatting that I needed when running from powerpoint that wasn't needed when converting to excel. This pulls every file from the list, opens, copies to a master powerpoint with formatting intact, and closes. in the end I have a new master powerpoint that has all of the presentations that are on the list
Sub tmp()
'Set a VBE reference to Microsoft PowerPoint Object Library
Application.CutCopyMode = False
On Error GoTo ErrorHandler
Dim PPApp As PowerPoint.Application
Dim i As Integer, j As Integer
Dim pres1 As PowerPoint.Presentation, new_pres As PowerPoint.Presentation
Dim oslide As PowerPoint.Slide, s As PowerPoint.Slide, oSld As PowerPoint.Slide
Dim oShape As PowerPoint.Shape, oSh As PowerPoint.Shape, oshp As PowerPoint.Shape
Dim PPShape As Object
Dim wb As Workbook
Dim list As Worksheet
Set PPApp = CreateObject("Powerpoint.Application")
PPApp.Visible = True
Set new_pres = PPApp.Presentations.Add
Set wb = ThisWorkbook
Set list = wb.Worksheets("Powerpoint File List")
LastRow = list.Range("A" & Rows.Count).End(xlUp).Row
new_pres.PageSetup.SlideSize = ppSlideSizeOnScreen
' this is not working
k = 1
For i = 1 To LastRow
filepath = list.Range("A" & i).Value
Set pres1 = PPApp.Presentations.Open(filepath)
For j = 1 To pres1.Slides.Count
pres1.Slides(j).Copy
new_pres.Slides.Paste
' new_pres.Slides.Paste
' new_pres.Application.CommandBars.ExecuteMso ("PasteSourceFormatting")
k = k + 1
Next j
pres1.Close
Set pres1 = Nothing
Next i
For Each oSld In new_pres.Slides
oSld.HeadersFooters.Clear
oSld.HeadersFooters.SlideNumber.Visible = msoFalse
oSld.HeadersFooters.DateAndTime.Visible = msoFalse
Next oSld
With new_pres.SlideMaster.Shapes
Set oshp = .AddTextbox(msoTextOrientationHorizontal, 700, 520, 100, 50)
oshp.TextFrame.TextRange.Font.Name = "Arial"
oshp.TextFrame.TextRange.Font.Size = 7
oshp.TextFrame.TextRange.InsertSlideNumber
End With
'ActivePresentation.PageSetup.FirstSlideNumber = 0
new_pres.Slides(1).DisplayMasterShapes = msoTrue
Set oshp = Nothing
response = MsgBox(prompt:="Is this For Official Use Only?", Buttons:=vbYesNo)
If response = vbYes Then
txt = "For Official Use Only"
' If statement to check if the yes button was selected.
Else
' The no button was selected.
MsgBox "Then it is assumed this is a Boeing Proprietary presentation"
txt = "Boeing Proprietary"
End If
With new_pres.SlideMaster.Shapes
Set oshp = .AddTextbox(msoTextOrientationHorizontal, 300, 520, 100, 50)
oshp.TextFrame.TextRange.Font.Name = "Arial"
oshp.TextFrame.TextRange.Font.Size = 7
oshp.TextFrame.TextRange.Text = txt
End With
injdate = InputBox("Please enter the date for the Stand Up")
With new_pres.SlideMaster.Shapes
Set oshp = .AddTextbox(msoTextOrientationHorizontal, 10, 520, 100, 50)
oshp.TextFrame.TextRange.Font.Name = "Arial"
oshp.TextFrame.TextRange.Font.Size = 7
oshp.TextFrame.TextRange.Text = injdate
End With
Application.CutCopyMode = True
NormalExit:
Exit Sub
ErrorHandler:
Call MsgBox("Error:" & vbCrLf & Err.Number & vbCrLf & Err.Description, _
vbOKOnly, "Error inserting files")
Resume NormalExit
End Sub