Zip mutipleフォルダとその内容VBA

Question

複数のフォルダ（appox。400があり、場合によっては増加する可能性があります）があり、それぞれにいくつかのファイルが含まれています。私は、これらのすべてのフォルダをその内容で圧縮し、400のzipファイルを作成したかったのです。私はVBAでこれを自動化したかったのです。私は次のコードを試しました。シェルアプリケーションを使用する標準のもの。

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 

Sub NewZip(sPath) 
'Create empty Zip File 
    If Len(Dir(sPath)) > 0 Then Kill sPath 
    Open sPath For Output As #1 
    Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0) 
    Close #1 
End Sub 

ループ内で上記のコードを呼び出して、複数のzipフォルダを作成することができます。しかし、これが本当にエフェクトプロセスであるかどうかは疑問でした。この手続きの代替手段はありますか？時々、私のフォルダの数は圧縮されるかもしれませんが、私はあなたの提案とアイデアを本当にありがとうと思います。

あなたは400個の別のフォルダに分け、すべてを必要としない場合、あなたは1つのzip形式のフォルダにそれらすべてを組み合わせることができ、まあ事前

Answer 1

でいただきありがとうございます。

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 
Sub NewZip(sPath) 
'Create empty Zip File 
'Changed by keepITcool Dec-12-2005 
    If Len(Dir(sPath)) > 0 Then Kill sPath 
    Open sPath For Output As #1 
    Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0) 
    Close #1 
End Sub 


Function bIsBookOpen(ByRef szBookName As String) As Boolean 
' Rob Bovey 
    On Error Resume Next 
    bIsBookOpen = Not (Application.Workbooks(szBookName) Is Nothing) 
End Function 


Function Split97(sStr As Variant, sdelim As String) As Variant 
'Tom Ogilvy 
    Split97 = Evaluate("{""" & _ 
         Application.Substitute(sStr, sdelim, """,""") & """}") 
End Function 

https://www.rondebruin.nl/win/s7/win001.htm