Question

Sub Combine_ppt()

Dim parent As PowerPoint.Application
Dim child As PowerPoint.Application
Dim pname, cname As String

pname = "C:\PPT\ParentFile.ppt"
On Error Resume Next
Set parent = CreateObject("PowerPoint.Application")
parent.Presentations.Open pname
On Error GoTo 0
If parent Is Nothing Then
    MsgBox "Parent File not Found"
    Exit Sub
End If
parent.Visible = True
fld = "C:\PPT\"
cname = Dir(fld & "*Child*.ppt")
Do While cname <> ""
    Set child = CreateObject("PowerPoint.Application")
    child.Presentations.Open "C:\PPT\" & cname
    ccount = child.ActivePresentation.Slides.Count
    For i = 1 To ccount
        child.ActivePresentation.Slides(i).copy
        parent.ActivePresentation.Slides.Paste
    Next i
    child.Quit
    Set child = Nothing
Loop
End Sub

我正在尝试将所有ppt中的幻灯片从其文件名中的“child”复制到父ppt。当我运行代码时，我看到复制的幻灯片被粘贴到同一个演示文稿而不是父代，并且代码也会进入无限循环，一次又一次地打开同一个子文件，而不是继续移动另一个子文件文件夹。请建议。

Answer 1

您没有循环遍历Dir中的所有文件，因为您错过了为每个文件调用Dir

你只需要在循环结束时添加一个句子

cname = Dir(fld & "*Child*.ppt")
Do While cname <> ""
   ...
   cname=Dir()
Loop

Answer 2

我如下所示对其进行修改

Sub Combine_ppt()

    Dim parent As PowerPoint.Application
    Dim child As PowerPoint.Application
    Dim pname, cname As String

    pfname = "123.pptx"
    pname = "D:\temp\PPT\" & pfname
    On Error Resume Next
    Set parent = CreateObject("PowerPoint.Application")
    parent.Presentations.Open pname
    On Error GoTo 0
    If parent Is Nothing Then
        MsgBox "Parent File not Found"
    Exit Sub
    End If
    parent.Visible = True
    fld = "D:\temp\PPT\"
    cname = Dir(fld & "*child*.pptx")
    Do While cname <> ""
        Set child = CreateObject("PowerPoint.Application")
        child.Presentations.Open "D:\temp\PPT\" & cname
        ccount = child.ActivePresentation.Slides.Count

        For i = 1 To ccount
            'child.ActivePresentation.Slides(i).Copy
            Presentations(child.ActivePresentation.Name).Slides(i).Copy
            'Presentations("ParentFile.pptx").Slides.Paste
            Presentations(pfname).Slides.Paste

        Next i

        'child.Quit
        Presentations(child.ActivePresentation.Name).Close
        Set child = Nothing
        cname = Dir()
    Loop

End Sub

将幻灯片从多个ppt文件复制到单个ppt文件

2 个答案: