VBA .CopyHere - 將多個文件複製到ZIP文件？

下面的代碼將一個名爲「Images」的文件夾添加到我的zip文件中。我不想將Images文件夾作爲壓縮文件的子文件夾 - 我如何才能將Images文件夾的內容添加到壓縮文件的根目錄？而FolderToAdd & "*.*"不起作用。VBA .CopyHere - 將多個文件複製到ZIP文件？

Sub testing() 
Dim ZipFile As String 
Dim FolderToAdd As String 
Dim objShell As Object 
Dim varZipFile As Variant 

ZipFile = "C:\ZipFile_Images\images.zip" 
FolderToAdd = "C:\Images" 

Set objShell = CreateObject("Shell.Application") 
varZipFile = ZipFile 

If Right$(FolderToAdd, 1) <> "\" Then 
    FolderToAdd = FolderToAdd & "\" 
End If 

objShell.NameSpace(varZipFile).CopyHere (FolderToAdd) 
End Sub

背景：我把這個代碼將一次添加文件的一個給定的zip文件的功能，但增加100個個小JPEG文件時，這將需要大量的時間。一次添加整個文件夾大約快50倍。

最終，我只是希望能夠一次添加多個文件，所以我也可以打開其他代碼片段。

來源

2016-12-06 Warren

每次向zip文件添加任何內容時，都需要從頭開始重建。因此，一次添加一個文件將會很慢。將您的文件複製到臨時文件夾並壓縮臨時文件夾。 – 2016-12-06 05:04:24

羅恩去熊先生的頁面在這裏：http://www.rondebruin.nl/win/s7/win001.htm

你應該能夠適應這一點。

關鍵部分是：

oApp.Namespace(FileNameZip).CopyHere oApp.Namespace(FolderName).items

上市：

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

來源

2016-12-06 04:43:44

除了蒂姆·威廉姆斯的回答，下面是讓我的代碼工作的編輯 - 注意通過指定的兩個非常小的變化評論線。

Sub testing() 
Dim ZipFile As String 
'Dim FolderToAdd As String 
Dim FolderToAdd 
Dim objShell As Object 
Dim varZipFile As Variant 

ZipFile = "C:\ZipFile_Images\images.zip" 
FolderToAdd = "C:\Images" 

Set objShell = CreateObject("Shell.Application") 
varZipFile = ZipFile 

If Right$(FolderToAdd, 1) <> "\" Then 
    FolderToAdd = FolderToAdd & "\" 
End If 

'objShell.NameSpace(varZipFile).CopyHere (FolderToAdd) 
objShell.namespace(varZipFile).CopyHere objShell.namespace(FolderToAdd).Items 
End Sub

來源

2016-12-06 05:15:48 Warren

VBA .CopyHere - 將多個文件複製到ZIP文件？

回答

相關問題