用VBA批量合并PPT

leida_wt

于 2023-06-12 16:43:22 发布

阅读量729

点赞数 1

文章标签： powerpoint vba

本文链接：https://blog.csdn.net/leida_wt/article/details/131172039

版权

该VBA脚本能将一个文件夹内所有PPT自动合并到当前PPT中，每个新添加的幻灯片前会附带源文件的路径作为标题。用户需在PowerPoint中打开VisualBasic编辑器，创建新模块并输入脚本，然后执行以完成合并。

摘要生成于 C知道，由 DeepSeek-R1 满血版支持，前往体验 >

VBA脚本

本脚本将文件夹下所有ppt合并到当前ppt中，并在每个ppt前添加包含文件路径的标题页。

Sub InsertAllSlides()
'  Insert all slides from all presentations in the same folder as this one
'  INTO this one; do not attempt to insert THIS file into itself, though.

    Dim vArray() As String
    Dim x As Long
    

    ' Change "*.PPT" to "*.PPTX" or whatever if necessary:
    EnumerateFiles ActivePresentation.Path & "\", "*.PPT", vArray

    With ActivePresentation
        For x = 1 To UBound(vArray)
            If Len(vArray(x)) > 0 Then
                Set TitleSlide = .Slides.Add(.Slides.Count + 1, 11)
                TitleSlide.Shapes.Title.TextFrame.TextRange.Text = vArray(x)
                
                .Slides.InsertFromFile vArray(x), .Slides.Count
            End If
        Next
    End With

End Sub

Sub EnumerateFiles(ByVal sDirectory As String, _
    ByVal sFileSpec As String, _
    ByRef vArray As Variant)
    ' collect all files matching the file spec into vArray, an array of strings

    Dim sTemp As String
    ReDim vArray(1 To 1)

    sTemp = Dir$(sDirectory & sFileSpec)
    Do While Len(sTemp) > 0
        ' NOT the "mother ship" ... current presentation
        If sTemp <> ActivePresentation.Name Then
            ReDim Preserve vArray(1 To UBound(vArray) + 1)
            vArray(UBound(vArray)) = sDirectory & sTemp
        End If
        sTemp = Dir$
    Loop

End Sub