压缩文件夹中除了压缩包本身以外的所有文件

Question

压缩文件夹中除了压缩包本身以外的所有文件

10

我正在使用这段代码将文件夹中的所有文件压缩到一个新创建的.zip文件中：

Dim FileNameZip, FolderName
Dim filename As String, DefPath As String
Dim oApp As Object

(defining all paths needed)

'Create empty Zip File
NewZip (FileNameZip)

Set oApp = CreateObject("Shell.Application")
'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

只要目标文件夹与我的文件所在的文件夹不同，这个方法就可以顺利运行而不出问题。

但是当我试图将一个文件夹中的所有文件压缩成.zip并生成位于同一文件夹中的归档文件时，我遇到了一个问题——它会创建该归档文件，并尝试将其放入归档文件夹中，这当然会失败。

我正在寻找一种方法，可以压缩除新创建的文件以外的文件夹中的所有文件。

我在这里找到了资料：https://msdn.microsoft.com/en-us/library/office/ff869597.aspx，但这看起来非常适用于Outlook，我没有办法将其应用到Windows文件夹中。

- jacek_wi

也许您在创建新的 zip 文件之前先存储这些项目？ - PatricK

下面有一些很好的基于VBA的答案，但请注意，由于所有文件操作都需要时间，特别是归档，因此VBA将需要很长时间来运行。您可能希望考虑通过外壳调用命令行，并让批处理文件执行此操作。https://dev59.com/f2Mm5IYBdhLWcg3whfWe VBA环境将在完成此操作时保持响应。 - S Meaden

3个回答

5

我会在临时文件夹中创建zip文件，最后将其移动到目标文件夹。值得一提的两点是：

1- 循环直到文件夹和zip文件中的项目数相同的方法很危险，因为如果一个项目的压缩失败，就会导致无限循环。因此，最好循环直到Shell锁定zip文件。

2- 我将使用早期绑定和Shell，因为在某些安装中，晚期绑定Shell32.Application似乎存在问题。添加对Microsoft Shell Controls and Automation的引用。

Sub compressFolder(folderToCompress As String, targetZip As String)
    If Len(Dir(targetZip)) > 0 Then Kill targetZip

    ' Create a temporary zip file in the temp folder
    Dim tempZip As String: tempZip = Environ$("temp") & "\" & "tempzip1234.zip"
   CreateObject("Scripting.FileSystemObject").CreateTextFile(tempZip, True).Write _
        Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)

    ' compress the folder into the temporary zip file
    With New Shell ' For late binding: With CreateObject("Shell32.Application")
        .Namespace(tempZip).CopyHere .Namespace(folderToCompress).Items
    End With

    ' Move the temp zip to target. Loop until the move succeeds. It won't
    ' succeed until the zip completes because zip file is locked by the shell
    On Error Resume Next
    Do Until Len(Dir(targetZip)) > 0
        Application.Wait Now + TimeSerial(0, 0, 1)
        Name tempZip As targetZip
    Loop
End Sub

Sub someTest()
   compressFolder "C:\SO\SOZip", "C:\SO\SOZip\Test.zip"
End Sub

- A.S.H

2

值得记录的是 Name tempZip As targetZip https://msdn.microsoft.com/en-us/library/office/gg264639(v=office.15).aspx。个人之前从未见过这种写法。感谢您教给我新的知识。 - S Meaden

哇，有没有创建带有这些前导ASCII代码的zip文件的文档链接？ - S Meaden

1

@SMeaden 不用谢，我每天都在SO上学到新东西：）。 OP使用了newZip函数，它正是这样做的，而且这个序列在网络上早已被广泛知晓。这里是一个很好的起点。 - A.S.H

这会生成“编译错误：未定义的用户类型”，并突出显示New Shell。它应该是“NewShell”，并且之前定义为变量吗？ - jacek_wi

@jacek_wi 正如我所说，你应该在VB编辑器中添加对Microsoft Shell Controls and Automation的引用。否则，你可以使用后期绑定：With CreateObject("Shell32.Application")。 - A.S.H

0

我发现通过VBA进行文件压缩很难在没有第三方工具的情况下进行控制，以下可能不是一个直接的答案，但可能会作为一种解决方案。以下是我用来生成epub的代码摘录，它们与具有不同扩展名的zip文件没有太大区别。这个压缩部分在数百次运行中从未失败。

Public Function Zip_Create(ByVal StrFilePath As String) As Boolean
Dim FSO         As New FileSystemObject
Dim LngCounter  As Long

If Not FSO.FileExists(StrFilePath) Then
    'This makes the zip file, note the FilePath also caused issues
    'it should be a local file, suggest root of a drive and then use FSO
    'to open it
    LngCounter = FreeFile
    Open StrFilePath For Output As #LngCounter
    Print #LngCounter, "PK" & Chr(5) & Chr(6) & String(18, vbNullChar)
    Close #LngCounter
End If

Zip_Create = True

End Function

Public Function Zip_Insert(ByVal StrZipFilePath As String, ByVal StrObject As String) As Boolean
Dim BlnYesNo            As Boolean
Dim LngCounter          As Long
Dim LngCounter2         As Long
Dim ObjApp              As Object
Dim ObjFldrItm          As Object
Dim ObjFldrItms         As Object
Dim StrContainer        As String
Dim StrContainer2       As String

If Procs.Global_IsAPC Then

    'Create the zip if needed
    If Not FSA.File_Exists(StrZipFilePath) Then
        If Not Zip_Create(StrZipFilePath) Then
            Exit Function
        End If
    End If

    'Connect to the OS Shell
    Set ObjApp = CreateObject("Shell.Application")

        'Pause, if it has just been created the next piece of
        'code may not see it yet
        LngCounter2 = Round(Timer) + 1
        Do Until CLng(Timer) > LngCounter2
            DoEvents
        Loop

        'Divide the path and file
        StrContainer = Right(StrObject, Len(StrObject) - InStrRev(StrObject, "\"))
        StrObject = Left(StrObject, Len(StrObject) - Len(StrContainer))

        'Connect to the file (via the path)
        Set ObjFldrItm = ObjApp.NameSpace(CVar(StrObject)).Items.Item(CVar(StrContainer))

            'Pauses needed to avoid all crashes
            LngCounter2 = CLng(Timer) + 1
            Do Until CLng(Timer) > LngCounter2
                DoEvents
            Loop

            'If it is a folder then check there are items to copy (so as to not cause and error message
            BlnYesNo = True
            If ObjFldrItm.IsFolder Then
                If ObjFldrItm.GetFolder.Items.Count = 0 Then BlnYesNo = False
            End If

            If BlnYesNo Then

                'Take note of how many items are in the Zip file

                'Place item into the Zip file
                ObjApp.NameSpace(CVar(StrZipFilePath)).CopyHere ObjFldrItm

                'Pause to stop crashes
                LngCounter2 = CLng(Timer) + 1
                Do Until CLng(Timer) > LngCounter2
                    DoEvents
                Loop

                'Be Happy
                Zip_Insert = True

            End If

        Set ObjFldrItm = Nothing

    Set ObjApp = Nothing
End If

End Function

- Gary Evans

网页内容由stack overflow 提供, 点击上面的

可以查看英文原文，
原文链接

- Absinthe · Accepted Answer

不要一次性添加所有文件，这会包括您创建的zip文件，请使用FileSystemObject循环遍历文件，并在将其添加到zip之前将它们的名称与zip文件名进行比较：

Sub AddFilesToZip()

Dim fso As Object, zipFile As Object, objShell As Object
Dim fsoFolder As Object, fsoFile As Object
Dim timerStart As Single
Dim folderPath As String, zipName As String

folderPath = "C:\Users\darre\Desktop\New folder\" ' folder to zip
zipName = "myzipfile.zip" ' name of the zip file

Set fso = CreateObject("Scripting.FileSystemObject") ' create an fso to loop through the files

Set zipFile = fso.CreateTextFile(folderPath & zipName) ' create the zip file
zipFile.WriteLine Chr(80) & Chr(75) & Chr(5) & Chr(6) & String(18, 0)
zipFile.Close

Set objShell = CreateObject("Shell.Application")
Set fsoFolder = fso.GetFolder(folderPath)

For Each fsoFile In fsoFolder.Files ' loop through the files...

    Debug.Print fsoFile.name
    If fsoFile.name <> zipName Then ' and check it's not the zip file before adding them

        objShell.Namespace("" & folderPath & zipName).CopyHere fsoFile.Path

        timerStart = Timer
        Do While Timer < timerStart + 2
            Application.StatusBar = "Zipping, please wait..."
            DoEvents
        Loop

    End If

Next

' clean up
Application.StatusBar = ""
Set fsoFile = Nothing
Set fsoFolder = Nothing
Set objShell = Nothing
Set zipFile = Nothing
Set fso = Nothing

MsgBox "Zipped", vbInformation

End Sub