合并文件夹及子文件夹中PowerPoint文件时出现重复幻灯片问题

我尝试运行以下VBA代码，该代码可递归遍历当前演示文稿所在的文件夹及子文件夹，将所有PowerPoint文档合并为单个文件，但有时会出现重复遍历的情况，导致第一轮遍历完成后幻灯片被重复添加。请问是什么原因导致该问题？

Sub loopAllSubFolderSelectStartDirectory()

    Dim FSOLibrary As Object
    Dim FSOFolder As Object
    Dim folderName As String

    folderName = ActivePresentation.Path
    If Len(folderName) > 0 Then
        MsgBox ActivePresentation.Name & vbNewLine & "saved under" & vbNewLine & folderName
    Else
        MsgBox "File not saved"
    End If

    'Set the reference to the FSO Library
    Set FSOLibrary = CreateObject("Scripting.FileSystemObject")

    'Another Macro must call LoopAllSubFolders Macro to start
    LoopAllSubFolders FSOLibrary.GetFolder(folderName)

End Sub

Sub LoopAllSubFolders(FSOFolder As Object)

    Dim FSOSubFolder As Object
    Dim FSOFile As Object

    'For each subfolder call the macro
    For Each FSOSubFolder In FSOFolder.subfolders
        LoopAllSubFolders FSOSubFolder
    Next

    On Error GoTo DoNext
    'For each file, print the name
    For Each FSOFile In FSOFolder.Files

        'Insert the actions to be performed on each file
        'This example will print the full file path to the immediate window
        Debug.Print FSOFile.Path

        With ActivePresentation
            .Slides.Add Index:=.Slides.Count + 1, Layout:=ppLayoutCustom
            With ActivePresentation.Slides(.Slides.Count)
                .FollowMasterBackground = False
                .Background.Fill.Solid
                .Background.Fill.ForeColor.RGB = RGB(255, 0, 0)
            
                .Shapes.Title.TextFrame.TextRange.Text = FSOFile.Path
                .Shapes.Title.TextFrame.TextRange.Font.Color = RGB(255, 255, 255)
            End With
        
            .Slides.InsertFromFile FSOFile.Path, .Slides.Count
        End With

DoNext:
    Next

End Sub

原因分析 #

• 未过滤目标文件类型及当前演示文稿：代码遍历文件夹下所有文件，包括正在编辑的当前演示文稿本身。当遍历到当前文件时，InsertFromFile会将当前文件的幻灯片再次插入，直接造成重复。同时，非PPT格式的文件（如文档、表格）触发InsertFromFile时会报错，被On Error GoTo DoNext跳过，可能导致遍历逻辑出现异常分支。

• 错误处理掩盖了异常：全局的On Error GoTo DoNext会跳过所有错误，包括文件无法打开、权限不足等问题。如果某一文件处理失败后，后续遍历逻辑可能因错误状态未重置，出现重复执行或逻辑偏移的情况。

• 递归遍历未排除特殊目录：如果文件夹存在软链接、快捷方式指向父目录或已遍历目录，会导致递归陷入循环，重复遍历同一文件夹下的文件，造成幻灯片重复添加。

修正方案 #

1. 添加文件类型过滤与当前文件排除
   在文件遍历循环内增加判断，仅处理PPT/PPTX/PPTM格式文件，并跳过当前演示文稿：

   ' 在For Each FSOFile In FSOFolder.Files循环开头添加
   Dim fileExt As String
   Dim FSOLibrary As Object
   Set FSOLibrary = CreateObject("Scripting.FileSystemObject")
   fileExt = LCase(FSOLibrary.GetExtensionName(FSOFile.Path))
   
   ' 仅处理PPT相关格式，且排除当前正在编辑的文件
   If (fileExt = "ppt" Or fileExt = "pptx" Or fileExt = "pptm") And FSOFile.Path <> ActivePresentation.FullName Then
       ' 原有的幻灯片插入逻辑
   End If
   

2. 优化错误处理逻辑
   移除全局的错误跳转，改为针对特定错误处理，避免掩盖异常：

   ' 替换原有的On Error GoTo DoNext
   On Error Resume Next
   .Slides.InsertFromFile FSOFile.Path, .Slides.Count
   ' 捕获并处理插入失败的情况
   If Err.Number <> 0 Then
       Debug.Print "插入失败：" & FSOFile.Path & "，错误码：" & Err.Number
       Err.Clear
   End If
   On Error GoTo 0
   

3. 排除特殊目录（可选）
   若存在软链接/快捷方式，可在递归遍历子文件夹时判断是否为链接，跳过循环目录：

   For Each FSOSubFolder In FSOFolder.subfolders
       ' 跳过快捷方式/软链接目录
       If Not FSOSubFolder.IsLink Then
           LoopAllSubFolders FSOSubFolder
       End If
   Next
   

内容的提问来源于stack exchange，提问作者Miguel de las Nieves