压缩zip存档本身以外的文件夹中的所有文件

Question

我使用此代码将文件夹中的所有文件压缩到新创建的.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文件夹.

Answer 1

而不是一次添加所有文件(包括您创建的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

Answer 2

我会在临时文件夹中创建zip文件,最后将其移动到目标文件夹.值得一提的两个注意事项:

1-循环直到Item计数在文件夹和zip文件中相同的方法是有风险的,因为如果单个项目的压缩失败,则会导致无限循环.因此,只要zip文件被shell锁定,就最好循环.

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