批量压缩文件夹

a-telnet

Sub CompressFolders()
    Dim FolderPath As String
    Dim FSO As Object
    Dim SourceFolder As Object
    Dim SubFolder As Object
    Dim FileItem As Object
    Dim ShellApp As Object

    ' 设置文件夹路径
    FolderPath = "C:\Your\Folder\Path"

    ' 创建文件系统对象
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set SourceFolder = FSO.GetFolder(FolderPath)

    ' 创建Shell对象
    Set ShellApp = CreateObject("Shell.Application")

    ' 遍历文件夹中的子文件夹
    For Each SubFolder In SourceFolder.SubFolders
        ' 创建一个新的压缩包
        ShellApp.Namespace(FolderPath & "\" & SubFolder.Name & ".zip").CopyHere SubFolder.Path

        ' 等待压缩完成
        On Error Resume Next
        Do Until ShellApp.Namespace(FolderPath & "\" & SubFolder.Name & ".zip").Items.Count = FSO.GetFolder(SubFolder.Path).Files.Count
            Application.Wait (Now + TimeValue("0:00:01"))
        Loop
        On Error GoTo 0
    Next SubFolder

    ' 释放对象
    Set FileItem = Nothing
    Set SubFolder = Nothing
    Set SourceFolder = Nothing
    Set FSO = Nothing
    Set ShellApp = Nothing

    MsgBox "压缩完成！"
End Sub
运行提示 91错误，ShellApp.Namespace(FolderPath & "\" & SubFolder.Name & ".zip").CopyHere SubFolder.Path

安永飞

Sub CompressFolders()  
    Dim FolderPath As String  
    Dim FSO As Object  
    Dim SourceFolder As Object  
    Dim SubFolder As Object  
    Dim FileItem As Object  
    Dim ShellApp As Object  
  
    ' 设置文件夹路径  
    FolderPath = "C:\Your\Folder\Path"  
  
    ' 创建文件系统对象  
    Set FSO = CreateObject("Scripting.FileSystemObject")  
    Set SourceFolder = FSO.GetFolder(FolderPath)  
  
    ' 创建Shell对象  
    Set ShellApp = CreateObject("Shell.Application")  
  
    ' 遍历文件夹中的子文件夹  
    For Each SubFolder In SourceFolder.SubFolders  
        ' 创建一个新的压缩包  
        ShellApp.NameSpace(FolderPath & "\" & SubFolder.Name & ".zip").CopyHere SubFolder.Path & "\*"  
  
        ' 等待压缩完成  
        On Error Resume Next  
        Do Until ShellApp.NameSpaces(FolderPath & "\" & SubFolder.Name & ".zip").Items.Count = FSO.GetFolder(SubFolder.Path).Files.Count  
            Application.Wait (Now + TimeValue("0:00:01"))  
        Loop  
        On Error GoTo 0  
    Next SubFolder  
  
    ' 释放对象  
    Set FileItem = Nothing  
    Set SubFolder = Nothing  
    Set SourceFolder = Nothing  
    Set FSO = Nothing  
    Set ShellApp = Nothing  
  
    MsgBox "压缩完成！"  
End Sub

安永飞

这里我修改了 ShellApp.Namespace 为 ShellApp.NameSpace，并修改了 CopyHere 方法的参数。现在，它将复制子文件夹中的所有文件到新的压缩文件中。