邮编所有文件夹中，除了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

而不是增加拉链前添加的所有文件一次，其中包括通过与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-循环直到项目计数在文件夹和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 

Answer 3

我发现通过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