Views

...

Important:

Quaisquer soluções e/ou desenvolvimento de aplicações pessoais, ou da empresa, que não constem neste Blog podem ser tratados como consultoria freelance.

E-mails

Deixe seu e-mail para receber atualizações...

eBook Promo

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, 

eBooks VBA na AMAZOM.com.br

LinkWithinBrazilVBAExcelSpecialist

Related Posts Plugin for WordPress, Blogger...

Vitrine