VBA Access - Compactando e Descompactando arquivos - Zip and Unzip Files

| Blog Office VBA | Blog Excel | Blog Access |

Em algumas ocasiões precisamos exportar arquivos como parte do fluxo de trabalho dentro da nossa aplicação MS Access, invariavelmente seria muito bom que estes pudessem sair compactados. Mas, se há um ponto sensível com o Zip é o de que não há nenhuma maneira simples de 'Zipar' ou descompactar um arquivos sem depender de um utilitários de terceiros. E, ao pensar sobre isso, considere que a capacidade de 'Zipar' está integrada ao Windows Explorer. Parece haver alguma restrição de licenciamento.

Felizmente, Ron de Bruin forneceu-nos uma solução que envolve automatizar o Windows Explorer (aka Shell32). O objeto para compactação Shell32.Folder pode ser uma pasta real ou uma pasta Zip, disponível para manipulação como se fosse um Shell32.Folder. Assim podemos usar o "Copiar aqui", método do Shell32.Folder, para mover os arquivos para dentro e para fora do arquivo Zip.

Como Ron observou, há um bug sutil quando trata-se da recuperação do Shell32.Folder através do método Shell32.Applications Namespace. 

Portanto, este código não vai funcionar como esperado:

Dim s As String

Dim f As Object 'Shell32.Folder

Let s = "C:\MyZip.zip"

Set f = CreateObject("Shell.Application").Namespace(s)

f.CopyHere "C:\MyText.txt" 'Error occurs here

De acordo com a documentação do MSDN, se o Método Namespace falhar, o valor de retorno será nada, e  poderemos ter um erro aparentemente não relacionado (Error 91 "With or object variable not set"). É por isso que Ron de Bruin usa Variant na sua amostra. 

Convertendo a string em uma variante irá funcionar também:

Dim s As String

Dim f As Object 'Shell32.Folder

Let s = "C:\MyZip.zip"

Set f = CreateObject("Shell.Application").Namespace(CVar(s))

f.CopyHere "C:\MyText.txt"

Alternativamente, pode optar por referenciar a Shell32.dll (normalmente no Windows\System32), modo early bind. A Vinculação antecipada não está sujeita a erro. No entanto, nossa preferência será a de late bind, para evitar qualquer problema com versões que possam ocorrer durante a execução de código num computador diferente, sistemas operacionais diferentes, service packs diferentes e assim por diante.

Ainda assim, o modo early bind pode ser útil para o desenvolvimento e validação do seu código antes de mudá-lo definitivamente para late bind.

Outra questão com a qual precisamos lidar é a de que, por existir apenas um método ou o outro disponível, ("Copiar aqui" ou "Mover para cá") com o objeto Shell32.Folder, temos de considerar como devemos lidar com a nomeação dos arquivos que serão compactados, especialmente quando estivermos descompactando os arquivos que potencialmente têm o mesmo nome ou devem substituir os arquivos originais no diretório de destino. 

Isso pode ser resolvido de duas maneiras diferentes: 

1) Descompacte os arquivos em um diretório temporário, renomeando-os, em seguida, movendo-os para o diretório final ou;

2) Renomeie um arquivo antes de 'zipar', assim terá um nome único quando descompactar Zip e, portanto, poderá ser renomeado. 

A opção 1 é mais segura, mas exige a criação de um diretório temporário e a sua eventual limpeza, mas quando você tem controle sobre o que o diretório de destino conterá, a opção 2 é bastante simples.

Em qualquer abordagem, podemos usar o VBA para renomear um arquivo simplesmente como:

Name strUnzippedFile As strFinalFileName

Finalmente, ao usar Shell32, estamos essencialmente automatizando o aspecto visual do Windows Explorer. Assim, quando invocarmos um "Copiar aqui" (CopyHere), será equivalente a realmente arrastar um arquivo e soltá-lo numa pasta (ou um arquivo zip). Isto significa que virá com os componentes da interface do usuário que podem impor algumas questões, especialmente quando estivermos automatizando o processo. Neste caso, é preciso esperar até que a compressão seja concluída antes de tomarmos qualquer tipo de ação. Porque será uma ação interativa, que ocorre de forma assíncrona, precisaremos escrever um código de espera. 

O monitoramento de uma compressão fora do processo pode ser complicado e por isso desenvolveremos um salvaguarda, que abrange diferentes contingências, tais como a compressão ocorrendo muito rapidamente, ou quando há um atraso entre a caixa de diálogo de compressão.

Faremos isso de 3 maneiras diferentes:

a) Um timing após 3 segundos para os arquivos pequenos, 

b) Acompanhar a contagem de itens do arquivo Zip, 

c) e Monitorização da presença de compressão de diálogo. 

A última parte nos obriga a utilizar o método WScript.Shell object's AppActivate porque ao contrário do método de acesso embutido o WScript.Shell retornará um valor booleano que pode ser usado para determinar se a ativação foi bem sucedida ou não, e, portanto, implicará na presença / ausência do "Comprimir ..." diálogo sem um gerenciamento bagunçado da API.

Exemplo de uso

O código completo está abaixo para usar:

'Cria um novo arquivo Zip e Zipa o arquivo PDF

Zip "C:\Temp\MyNewZipFile.zip", "C:\Temp\MyPdf.pdf

'Unzip o PDF e coloca-o no mesmo diretório

Unzip "C:\Temp\MyNewZipFile.zip"

'Exemplo de múltipla compactação num simples arquivo Zip.

Zip "C:\Temp\MyZipFile.zip", "C:\Temp\A1.pdf"

Zip "C:\Temp\MyZipFile.zip", "C:\Temp\A2.pdf"

Zip "C:\Temp\MyZipFile.zip", "C:\Temp\A3.pdf"

'Descompacta um arquivo Zip com mais de um arquivo

'colocando-o nu mpasta compartilhada sobreescrevendo qualquer arquivo préexistente.

Unzip "C:\Temp\MyZipFile.zip", "Z:\Shared Folder\", True

Aqui está o algoritmo completo do procedimento para Zipar e Descompactar, basta copiá-lo num novo módulo VBA e aproveitar:

Private Declare Sub Sleep Lib "kernel32" ( _

    ByVal dwMilliseconds As Long _)

Public Sub Zip( _

    ZipFile As String, _

    InputFile As String _)

On Error GoTo ErrHandler

    Dim FSO As Object 'Scripting.FileSystemObject

    Dim oApp As Object 'Shell32.Shell

    Dim oFld As Object 'Shell32.Folder

    Dim oShl As Object 'WScript.Shell

    Dim i As Long

    Dim l As Long

    Set FSO = CreateObject("Scripting.FileSystemObject")

    If Not FSO.FileExists(ZipFile) Then

        'Create empty ZIP file

        FSO.CreateTextFile(ZipFile, True).Write _

            "PK" & Chr(5) & Chr(6) & String(18, vbNullChar)

    End If

    Set oApp = CreateObject("Shell.Application")

    Set oFld = oApp.NameSpace(CVar(ZipFile))

    Let i = oFld.Items.Count

    oFld.CopyHere (InputFile)

    Set oShl = CreateObject("WScript.Shell")

    'Search for a Compressing dialog

    Do While oShl.AppActivate("Compressing...") = False

        If oFld.Items.Count > i Then

            'There's a file in the zip file now, but

            'compressing may not be done just yet

            Exit Do

        End If

        If l > 30 Then

            '3 seconds has elapsed and no Compressing dialog

            'The zip may have completed too quickly so exiting

            Exit Do

        End If

        DoEvents

        Sleep 100

        Let l = l + 1

    Loop

    ' Wait for compression to complete before exiting

    Do While oShl.AppActivate("Compressing...") = True

        DoEvents

        Sleep 100

    Loop

ExitProc:

    On Error Resume Next

        Set FSO = Nothing

        Set oFld = Nothing

        Set oApp = Nothing

        Set oShl = Nothing

    Exit Sub

ErrHandler:

    Select Case Err.Number

        Case Else

            MsgBox "Error " & Err.Number & _

                   ": " & Err.Description, _

                   vbCritical, "Unexpected error"

    End Select

    Resume ExitProc

    Resume

End Sub

Public Sub UnZip( _

    ZipFile As String, _

    Optional TargetFolderPath As String = vbNullString, _

    Optional OverwriteFile As Boolean = False _)

On Error GoTo ErrHandler

    Dim oApp As Object

    Dim FSO As Object

    Dim fil As Object

    Dim DefPath As String

    Dim strDate As String

    Set FSO = CreateObject("Scripting.FileSystemObject")

 

   If Len(TargetFolderPath) = 0 Then

        Let DefPath = CurrentProject.Path & "\"

    Else

        If FSO.folderexists(TargetFolderPath) Then

            Let DefPath = TargetFolderPath & "\"

        Else

            Err.Raise 53, , "Folder not found"

        End If

    End If

    If FSO.FileExists(ZipFile) = False Then

        MsgBox "System could not find " & ZipFile _

            & " upgrade cancelled.", _

            vbInformation, "Error Unziping File"

        Exit Sub

    Else

        'Extract the files into the newly created folder

        Set oApp = CreateObject("Shell.Application")

        With oApp.NameSpace(ZipFile & "\")

            If OverwriteFile Then

                For Each fil In .Items

                    If FSO.FileExists(DefPath & fil.Name) Then

                        Kill DefPath & fil.Name

                    End If

                Next

            End If

            oApp.NameSpace(CVar(DefPath)).CopyHere .Items

        End With

        On Error Resume Next

        Kill Environ("Temp") & "\Temporary Directory*"

        'Kill zip file

        Kill ZipFile

    End If

ExitProc:

    On Error Resume Next

    Set oApp = Nothing

    Exit Sub

ErrHandler:

    Select Case Err.Number

        Case Else

            MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical, "Unexpected error"

    End Select

    Resume ExitProc

    Resume

End Sub

Reference: Ron de Bruin

Tags: VBA, Access, Zip, Unzip, compact, compactar, Shell32, Shell32.Folder, Shell32.Applications, Namespace, Dll, Shell32.dll, API,