无法让 Excel VBA 复制 PPT 文件

Question

我有以下代码，我尝试对其进行修改，使其遍历 excel 中的列表，打开列表中的每个 ppt 文件并将其复制到新的 ppt 文件中。但是它被挂断了，并且在循环过程中出现了错误。

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

我让它工作了，它是我在从 powerpoint 运行时需要的 PasteSourceFormatting，而在转换为 Excel 时不需要。这会从列表中提取每个文件，打开，复制到格式完整的主 powerpoint，然后关闭。最后，我有一个新的主幻灯片，其中包含列表中的所有演示文稿

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