Erstellen eines komprimierten (oder gezippten) Ordners

Question

Gibt es eine Möglichkeit, einen komprimierten Ordner in Windows programmgesteuert zu erstellen? Ich sehe keinen Weg, dies mit dem FileSystemObject zu tun (obwohl es das 'Compressed' Attribut gibt).

Ich habe Zip-DLLs gesehen, aber ich würde es vorziehen, zu vermeiden, eine DLL neu zu verteilen, wenn möglich. Windows XP unterstützt nativ komprimierte Ordner.

Answer 1

Werfen Sie einen Blick auf die folgenden Links:

http://www.rondebruin.nl/windowsxpzip.htm

http://forums.microsoft.com/MSDN/ShowPost.aspx?PostID=1383147&SiteID=1

die wichtigen Teile aus dem first link Beispiel Strippen kann als ausreichend erweisen.

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 Split97(sStr As Variant, sdelim As String) As Variant 
'Tom Ogilvy 
    Split97 = Evaluate("{""" & _ 
         Application.Substitute(sStr, sdelim, """,""") & """}") 
End Function 

Sub Zip_File_Or_Files() 
    Dim strDate As String, DefPath As String, sFName As String 
    Dim oApp As Object, iCtr As Long, I As Integer 
    Dim FName, vArr, FileNameZip 

    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" 

    'Browse to the file(s), use the Ctrl key to select more files 
    FName = Application.GetOpenFilename(filefilter:="Excel Files (*.xl*), *.xl*", _ 
        MultiSelect:=True, Title:="Select the files you want to zip") 
    If IsArray(FName) = False Then 
     'do nothing 
    Else 
     'Create empty Zip File 
     NewZip (FileNameZip) 
     Set oApp = CreateObject("Shell.Application") 
     I = 0 
     For iCtr = LBound(FName) To UBound(FName) 
      vArr = Split97(FName(iCtr), "\") 
      sFName = vArr(UBound(vArr)) 
      If bIsBookOpen(sFName) Then 
       MsgBox "You can't zip a file that is open!" & vbLf & _ 
         "Please close it and try again: " & FName(iCtr) 
      Else 
       'Copy the file to the compressed folder 
       I = I + 1 
       oApp.Namespace(FileNameZip).CopyHere FName(iCtr) 

       'Keep script waiting until Compressing is done 
       On Error Resume Next 
       Do Until oApp.Namespace(FileNameZip).items.Count = I 
        Application.Wait (Now + TimeValue("0:00:01")) 
       Loop 
       On Error GoTo 0 
      End If 
     Next iCtr 

     MsgBox "You find the zipfile here: " & FileNameZip 
    End If 
End Sub