vba - online - Creando una carpeta comprimida(o comprimida)

como descomprimir un archivo zip

Question

¿Hay alguna manera de crear programáticamente una carpeta comprimida en Windows? No puedo ver una manera de hacer esto usando el FileSystemObject (aunque existe el atributo ''Compressed'').

He visto zip dll pero preferiría evitar tener que volver a distribuir un archivo DLL si es posible. Windows XP soporta nativamente carpetas comprimidas después de todo.

Answer 1

Eche un vistazo a los siguientes enlaces:

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

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

Pelar las partes importantes del primer ejemplo de enlace puede ser suficiente.

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