如何合并这些VBA子?

时间:2018-07-16 23:34:21

标签: powerpoint-vba

我用此代码的目标是要有一个文件夹PATH,宏将进行搜索并将每个PPT幻灯片插入新的演示文稿中。然后,宏将在下一个子文件夹中查找,并继续此迭代过程,直到将每张幻灯片添加到新的演示文稿中。

我真的很不擅长VBA编码,只是把我在网上可以找到的东西拼凑在一起,以便我可以更快地工作。

Public Sub NonRecursiveMethod()
Dim fso, ofolder, oSubfolder, oFile, queue As Collection
Dim vArray As Variant

Set fso = CreateObject("Scripting.FileSystemObject")
Set queue = New Collection
    queue.Add fso.GetFolder("\\PATH") 'obviously replace

    Do While queue.Count > 0
        Set ofolder = queue(1)
        queue.Remove 1 'dequeue
            'I don't know if I need to conduct any folder operations

        For Each oSubfolder In ofolder.SubFolders
            queue.Add oSubfolder 'enqueue
        Next oSubfolder
        For Each oFile In ofolder.Files
            'I understand that I need to call my InsertAllSlides method here, but how?    
        Next oFile
    Loop

End Sub

Sub InsertAllSlides(ByVal ofolder As String)

    Dim vArray() As String
    Dim x As Long

    EnumerateFiles "need to know which variable to add", "*.PPTX", vArray


    With ActivePresentation
    For x = 1 To UBound(vArray)
        If Len(vArray(x)) > 0 Then
            Debug.Print 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

0 个答案:

没有答案