VBA。コピー - 複数のファイルをZIPファイルにコピーしますか？

Question

以下のコードは、「画像」という名前のフォルダをZIPファイルに追加します。 Imagesフォルダをzipのサブフォルダにしたくないのですが、どうすればImageフォルダの内容をzipファイルのルートに追加するだけですか？そしてFolderToAdd & "*.*"は動作しません。

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倍速くなります。

最終的には、複数のファイルをネイティブに一度に追加できるようにしたいので、他のコードスニペットも開いています。

ここロン・ド・ブルーインのページから

Answer 1

：あなたはこれを適応することができるはず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 

Answer 2

、以下は私のコードを動作させるために編集され - で示される2つの非常に小さな変化に注意してください。コメント行。

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