如何修改VBA代码实现指定父文件夹下子文件夹批量压缩为Zip

核心修改说明 #

• 将原有的手动选文件夹压缩逻辑改为参数化过程，直接接收子文件夹路径，彻底移除重复选择步骤
• 在遍历子文件夹的流程中，自动传递当前子文件夹路径给压缩函数，实现全自动化批量处理

完整代码 #

Dim FileSystem As Object
Dim HostFolder As Variant
Dim SubFolder As Variant

''''''''''''''''''' 文件夹递归遍历 '''''''''''''''
Sub sample()
    HostFolder = GetFolder
    If HostFolder = "" Then Exit Sub ' 用户取消选择时直接退出
    
    Set FileSystem = CreateObject("Scripting.FileSystemObject")
    DoFolder FileSystem.GetFolder(HostFolder)
End Sub

Sub DoFolder(Folder)
    ' 遍历当前文件夹下的所有子文件夹
    For Each SubFolder In Folder.SubFolders
        Zip_Folder SubFolder.Path ' 直接传入子文件夹路径，自动压缩
        DoFolder SubFolder ' 递归处理子文件夹的子文件夹
    Next
    
    ' 保留原文件遍历逻辑，若无需处理文件可删除此段
    Dim File
    For Each File In Folder.Files
        ' 如需处理文件可在此添加逻辑
    Next
End Sub

Function GetFolder() As String
    Dim fldr As FileDialog
    Dim sItem As String
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "选择父文件夹"
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
    GetFolder = sItem
    Set fldr = Nothing
End Function

Sub Zip_Folder(folderPath As String)
'=============================================
'将指定文件夹压缩到其父目录下，生成同名ZIP文件
'基于RON DEBRUIN代码修改
'=============================================
    Dim FileNameZip, FolderName As String
    Dim oApp As Object
    Dim fso As Object
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set oApp = CreateObject("Shell.Application")
    
    ' 校验传入的文件夹路径有效性
    If Not fso.FolderExists(folderPath) Then
        MsgBox "指定文件夹不存在：" & folderPath, vbExclamation
        GoTo Cleanup
    End If
    
    FolderName = folderPath & "\" ' 确保路径以反斜杠结尾，避免Shell对象识别异常
    ' 生成ZIP文件名：父目录路径 + 子文件夹名称 + .zip后缀
    FileNameZip = fso.GetParentFolderName(folderPath) & "\" & fso.GetFileName(folderPath) & ".zip"
    
    ' 创建空ZIP文件容器
    NewZip FileNameZip
    
    ' 复制文件夹内所有内容到ZIP文件
    oApp.Namespace(FileNameZip).CopyHere oApp.Namespace(FolderName).Items
    
    ' 等待压缩完成（处理大量图片时需等待文件写入完成）
    On Error Resume Next
        Do Until oApp.Namespace(FileNameZip).Items.Count = oApp.Namespace(FolderName).Items.Count
            Application.Wait (Now + TimeValue("0:00:01"))
        Loop
    On Error GoTo 0
    
Cleanup:
    Set oApp = Nothing
    Set fso = Nothing
End Sub

Sub NewZip(sPath As String)
'=============================================
'创建空ZIP文件
'CHANGED BY KEEPITCOOL DEC-12-2005
'=============================================
    If Len(Dir(sPath)) > 0 Then Kill sPath
    Open sPath For Output As #1
    Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
    Close #1
End Sub

关键修改点解析 #

1. 参数化压缩函数：将原Zip_All_Files_in_Folder_Browse改为Zip_Folder，新增folderPath参数，直接使用传入路径生成ZIP文件，彻底移除BrowseForFolder弹窗逻辑。
2. 自动路径传递：在DoFolder的循环中，直接将遍历到的SubFolder.Path传给压缩函数，实现父文件夹下所有子文件夹的自动批量压缩。
3. 可靠路径处理：使用FileSystemObject的GetParentFolderName和GetFileName方法生成ZIP文件名，比原代码依赖Shell对象层级调用的方式更稳定。
4. 异常防护：添加文件夹存在性校验，避免无效路径导致的运行错误。

内容的提问来源于stack exchange，提问作者David Watson