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:

Postar um comentário

diHITT - Notícias