✔ Programação GLOBAL®: VBA Access - Compactando e Descompactando arquivos

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