Propósito

✔ Programação GLOBAL® - Quaisquer soluções e/ou desenvolvimento de aplicações pessoais, ou da empresa, que não constem neste Blog devem ser tratados como consultoria freelance. Queiram contatar-nos: brazilsalesforceeffectiveness@gmail.com | ESTE BLOG NÃO SE RESPONSABILIZA POR QUAISQUER DANOS PROVENIENTES DO USO DOS CÓDIGOS AQUI POSTADOS EM APLICAÇÕES PESSOAIS OU DE TERCEIROS.

.: Vitrine

Carregando artigos...

Views

Mostrando postagens com marcador unzip. Mostrar todas as postagens
Mostrando postagens com marcador unzip. Mostrar todas as postagens

VBA Tips - Compactando e Descompactando arquivos




Baixe o Calendário Compacto para 2014 em Excel



O que é o fenômeno chamado BIG DATA?



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.


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


Tags: VBA, Zip, compact, Compactar, zipping, unzip, 




Nenhum comentário:
Tags: , , , , ,

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, 

Nenhum comentário:
Tags: , , , , , , , , , , , ,
Assinar: Postagens (Atom)
diHITT - Notícias