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 폴더를 만들 수 있습니다. 그러나 이것이 정말로 효과적인 프로세스인지 궁금합니다. 이 절차에 대한 대안이 있습니까? 때로는 지퍼가 달린 폴더 수를 1000으로 늘릴 수도 있습니다. 따라서이 점에 대한 귀하의 제안과 아이디어에 진심으로 감사드립니다. 당신은, 당신은 하나 개의 압축 된 폴더에 모두 결합 할 수 있습니다 (400 개) 다른 폴더로 분리 모든 필요하지 않은 경우

은 사전

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