Question

我有多个文件夹（appox.400，在某些情况下会增加），每个文件夹都包含一些文件。我想将所有这些文件夹与其内容压缩并创建400个zip文件。我想用VBA自动化这个。我尝试使用以下代码。使用shell应用程序的标准版本。

Sub Zip_All_Files_in_Folder_Browse()
Dim FileNameZip, FolderName, oFolder
Dim strDate As String, DefPath As String
Dim oApp As Object

DefPath = Application.DefaultFilePath
If Right(DefPath, 1) <> "\" Then
    DefPath = DefPath & "\"
End If

strDate = Format(Now, " dd-mmm-yy h-mm-ss")
FileNameZip = DefPath & "MyFilesZip " & strDate & ".zip"

Set oApp = CreateObject("Shell.Application")

'Browse to the folder
Set oFolder = oApp.BrowseForFolder(0, "Select folder to Zip", 512)
If Not oFolder Is Nothing Then
    'Create empty Zip File
    NewZip (FileNameZip)

    FolderName = oFolder.Self.Path
    If Right(FolderName, 1) <> "\" Then
        FolderName = FolderName & "\"
    End If

    'Copy the files to the compressed folder
    oApp.Namespace(FileNameZip).CopyHere oApp.Namespace(FolderName).Items

        'Keep script waiting until Compressing is done
        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

        MsgBox "You find the zipfile here: " & FileNameZip

    End If
End Sub

Sub NewZip(sPath)
'Create empty Zip File
    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

我可以在循环中调用上面的代码来创建多个zip文件夹。但是，我想知道这是否真的是一个有效的过程！这个程序还有其他选择吗？有时候我要压缩的文件夹数可能会超过1000.所以我非常感谢你对此的建议和想法。

提前谢谢

Answer 1

好吧，如果您不需要将所有内容分成400个不同的文件夹，您可以将它们全部合并到一个压缩文件夹中。

Sub Zip_All_Files_in_Folder_Browse()
    Dim FileNameZip, FolderName, oFolder
    Dim strDate As String, DefPath As String
    Dim oApp As Object

    DefPath = Application.DefaultFilePath
    If Right(DefPath, 1) <> "\" Then
        DefPath = DefPath & "\"
    End If

    strDate = Format(Now, " dd-mmm-yy h-mm-ss")
    FileNameZip = DefPath & "MyFilesZip " & strDate & ".zip"

    Set oApp = CreateObject("Shell.Application")

    'Browse to the folder
    Set oFolder = oApp.BrowseForFolder(0, "Select folder to Zip", 512)
    If Not oFolder Is Nothing Then
        'Create empty Zip File
        NewZip (FileNameZip)

        FolderName = oFolder.Self.Path
        If Right(FolderName, 1) <> "\" Then
            FolderName = FolderName & "\"
        End If

        'Copy the files to the compressed folder
        oApp.Namespace(FileNameZip).CopyHere oApp.Namespace(FolderName).items

        'Keep script waiting until Compressing is done
        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

        MsgBox "You find the zipfile here: " & FileNameZip

    End If
End Sub
Sub NewZip(sPath)
'Create empty Zip File
'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


Function bIsBookOpen(ByRef szBookName As String) As Boolean
' Rob Bovey
    On Error Resume Next
    bIsBookOpen = Not (Application.Workbooks(szBookName) Is Nothing)
End Function


Function Split97(sStr As Variant, sdelim As String) As Variant
'Tom Ogilvy
    Split97 = Evaluate("{""" & _
                       Application.Substitute(sStr, sdelim, """,""") & """}")
End Function

https://www.rondebruin.nl/win/s7/win001.htm

Zip多个文件夹及其内容VBA

1 个答案: