VBA Tips - Compactando e Descompactando arquivos

Sim meus caros, existem relatórios repletos de dados pré-processados, contidos em cubos OLAP. os quais ficam enormes, e, enquanto espaço em disco tiver alguma importância, precisaremos compactá-los para distribuí-los.

Este primeiro código abaixo extrairá conteúdo de arquivos Zip. Note que o parâmetro "24" suprime qualquer janela de diálogo que possa existir encapsulada no arquivo compactado. O arquivo será automaticamente sobreposto.

Para maiores detalhes leia: http://msdn.microsoft.com/en-us/library/windows/desktop/bb787866(v=vs.85).aspx

Function UnZip (PathToUnzipFileTo As Variant, FileNameToUnzip As Variant)
    Dim objOApp As Object
    Dim varFileNameFolder As Variant

    Let varFileNameFolder = PathToUnzipFileTo

    Set objOApp = CreateObject("Shell.Application")

    objOApp.Namespace(varFileNameFolder).CopyHere objOApp.Namespace(FileNameToUnzip).items, 24
End Function

Sempre que possível, é bom termos um código diferente para aplicarmos uma técnica semelhante. Então segue mais um:

Sub UnZip(strTargetPath As String, Fname As Variant)
    Dim oApp As Object, FSOobj As Object
    Dim FileNameFolder As Variant

    If Right(strTargetPath, 1) <> Application.PathSeparator Then
        Let strTargetPath = strTargetPath & Application.PathSeparator
    End If

    Let FileNameFolder = strTargetPath

    'create destination folder if it does not exist
    Set FSOobj = CreateObject("Scripting.FilesystemObject")

    If FSOobj.FolderExists(FileNameFolder) = False Then
        FSOobj.CreateFolder FileNameFolder
    End If

    Set oApp = CreateObject("Shell.Application")

    oApp.Namespace(FileNameFolder).CopyHere oApp.Namespace(Fname).items

    Set oApp = Nothing
    Set FSOobj = Nothing
    Set FileNameFolder = Nothing
End Sub

Ahh, e claro, não há sentido em ensinar a descompactar e não ensinar a como compactar, não é mesmo? Divirtam-se!

Sub zip_activeworkbook()
    Dim strDate As String, DefPath As String
    Dim FileNameZip, FileNameXls
    Dim oApp As Object
    If ActiveWorkbook Is Nothing Then Exit Sub

    Let DefPath = ActiveWorkbook.Path

    If Len(DefPath) = 0 Then
        msgbox "Plz Save activeworkbook before zipping" & Space(12), vbInformation, "zipping"

        Exit Sub
    End If
   
    If Right(DefPath, 1) <> "\" Then
        Let DefPath = DefPath & "\"
    End If
    'Create date/time string and the temporary xls and zip file name
    Let strDate = Format(Now, " dd-mmm-yy h-mm-ss")
    Let FileNameZip = DefPath & Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 4) & strDate & ".zip"
    Let FileNameXls = DefPath & Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 4) & strDate & ".xls"
    If Dir(FileNameZip) = "" And Dir(FileNameXls) = "" Then
        'Make copy of the activeworkbook
        ActiveWorkbook.SaveCopyAs FileNameXls
        'Create empty Zip File
        newzip (FileNameZip)
        'Copy the file in the compressed folder
        Set oApp = CreateObject("Shell.Application")
       oApp.Namespace(FileNameZip).CopyHere FileNameXls
        'Keep script waiting until Compressing is done
        On Error Resume Next

        Do Until oApp.Namespace(FileNameZip).items.Count = 1
            Application.Wait (Now + TimeValue("0:00:01"))
        Loop

        On Error GoTo 0
        'Delete the temporary xls file
        Kill FileNameXls
        msgbox "completed zipped : " & vbNewLine & FileNameZip, vbInformation, "zipping"
    Else
        msgbox "FileNameZip or/and FileNameXls exist", vbInformation, "zipping"

    End If
End Sub

Private 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

fonte (http://www.dihitt.com/barra/vba-tips--compactando-e-descompactando-arquivos)