COMPRIMIR ARCHIVOS

Los archivos en formato ZIP probablemente sean los tipos de archivos mas utilizados, este ejemplo muestra como crear un archivo ZIP de un grupo de archivos seleccionados por el usuario con el método (Application.GetOpenFilename). Después crea un archivo llamado PruebaComprimir.zip en el directorio donde este guardado el Excel que contenga el siguiente procedimiento.

Sub ComprimirArchivos()

    Dim ShellApp As Object

    Dim FileNameZip As Variant

    Dim FileNames As Variant

    Dim i As Long, FileCount As Long

'   Obtener los nombres de los archivo

    FileNames = Application.GetOpenFilename _

        (FileFilter:="Todos los archivos. (*.*),*.*", _

         FilterIndex:=1, _

         Title:=" Seleccione los archivos para comprimir. ", _

         MultiSelect:=True)

'   Salir si se cancela el cuadro de diálogo

    If Not IsArray(FileNames) Then Exit Sub

  

    FileCount = UBound(FileNames)

    FileNameZip = Application.DefaultFilePath & "\PruebaComprimir.zip"

   

  

'   Crear archivo Zip vacío...

    Open FileNameZip For Output As #1

    Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)

    Close #1

    Set ShellApp = CreateObject("Shell.Application")

'   Copia los archivos a la carpeta comprimida

    For i = LBound(FileNames) To UBound(FileNames)

        ShellApp.Namespace(FileNameZip).CopyHere FileNames(i)

    Next i

    On Error Resume Next

    Do Until ShellApp.Namespace(FileNameZip).items.Count = FileCount

        Application.Wait (Now + TimeValue("0:00:01"))

    Loop

   

    If MsgBox(FileCount & " Los archivos se han comprimido en:" & _

       vbNewLine & FileNameZip & vbNewLine & vbNewLine & _

       " Quieres ver el archivo zip?", vbQuestion + vbYesNo) = vbYes Then _

       Shell "Explorer.exe /e," & FileNameZip, vbNormalFocus

End Sub