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, 

VBA Tips - Compatibilidade entre as API 32-Bits (x86) e 64-Bits (x64) no VBA

Inline image 1
| Blog Office VBA | Blog Excel | Blog Access |

Utilizar APIs tem se tornado uma complicação para alguns e isso deve-se ao fato de ser necessário compatibilizar as versões do MS Office e seus respectivos VBEs (ambientes de desenvolvimento).

A versão MS Office 2010, introduziu a plataforma 64 bits e a nova versão 7.0 do VBA.

Isso requer que todos aqueles que desenvolvem no ambiente MS Office atentem-se para manter a compatibilidade dos seus códigos em todas as plataformas, seja 32 Bits ou 64 Bits ou mesmo em versões anteriores. Prá quem já desenvolve a muito tempo isso não é novidade nenhuma, mas para os neofitos essa dica é bem relevante.

Lembrem-se desses ínfimos detalhes:

A versão do MS Office 2010 é a 14.0
A versão do MS Office 2007 é o 12.0
A versão do MS Office 2003 (XP) é o 11.0

O VBA tem a sua própria versão contida nos diferentes pacotes:

A versão VBA do MS Office 2007 é a 6.0
A versão VBA do MS Office 2010 é a 7.0

Divertido não?

Não fiquem demasiadamente preocupados com isso. O VBA 6.0 oferece uma ótima compatibilidade com as edições anteriores. Mas o VBA 7.0, do MS Office 2010 não.

Em tempo, faz-se necessário comentar que o cenário pode ser um pouco mais complexo quando nos referimos as versões 64 bits do MS Office, as quais foram introduzidas a partir do MS Office 2010. Estas não estão totalmente compatíveis com as versões 32 Bits do MS Office 2010.

Resumindo para os menos atentos:

MS Office 2010 64 bits
- VBA 7.0 - 64 bits

MS Office 2010 32 bits
- VBA 7.0 - 32 bits

MS Office 2007
ou anterior - VBA 6.0 ou anterior - 32 bits

E agora, quem poderá nos proteger?

Condicionais de Compilação
Os Condicionais de Compilação são instruções compiladas somente se o critério atender a condição. Possuem em seu prefixo o caractere #.

#If VBA7
Then
    ' Compilado somente no VBA do Office 2010, tanto nas versão 32 Bits, quanto na versão 64 Bits
     
     #If Win64 Then
        ' Compilado somente no VBA do Office 2010, na versão 64 Bits
     
     #Else
        ' Compilado somente no VBA do Office 2010, na versão 32 Bits
     #End If

#Else
    ' Compilado somente no VBA do Office 2007 ou inferior

#End If

Obs: Apesar do termo compilado as Condicionais podem ser inseridas dentro dos Procedimentos e podem ser depuradas.

Você que é desenvolvedor VBA, foque bem a sua atenção:

As suas declarações API devem ser cautelosas, veja o exemplo prático abaixo:

#If VBA7 Then
   Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr

   #If Win64 Then
      Declare PtrSafe Function GetTickCount64 Lib "kernel32" () As LongLong

   #Else
      Declare PtrSafe Function GetTickCount Lib "kernel32" () As Long

   #End If
#Else

   Declare Function GetActiveWindow Lib "user32" () As Long
   Declare Function GetTickCount Lib "kernel32" () As Long
#End If

Nesse exemplo, estamos usando as APIs GetActiveWindow e GetTickCount. Da forma como foram declaradas acima, são executadas em qualquer versão do MS Office. Perceba que deve efetuar as seguintes considerações caso a versão do VBA seja 7.0:

Veja detalhes aqui:

Adicionar o parâmetro PtrSafe entre Declare e Function (ou Sub)

Substituir Long por LongPtr

Observe que ao contrário da GetActiveWindow, a API GetTickCount deve ser declarada separadamente para as versões de 32 e 64 bits do Office 2010 (observe o sufixo 64 em GetTickCount64). Para APIs que estejam dentro do bloco Win64, a troca de variáveis tipo Long deve ser por LongLong, que é um novo tipo de inteiro de 64 bits que trabalha em ambiente 32 bits.

A parte difícil vem agora: nem todos os tipos Long devem ser convertidos. Numa explicação curta, podemos dizer que as APIs são definidas em linguagem C++, e nesta plataforma existem dois tipos numéricos não presentes no VBA: ponteiros e handles. Apenas ponteiros e handles devem ser transformados de Long para LongPtr. Como saber quais Long são handles e ponteiros? Teoricamente, o usuário deverá entrar na documentação da função no site da MSDN da Microsoft e ver quais são os parâmetros da função API desejada. Isso é um custo muito alto para o programador, e devido à reclamações da comunidade, a Microsoft lançou uma lista com as novas API para a plataforma 32 e 64 bits já corrigidas, que pode ser acessada através deste link.

Outro exemplo para o seu deleite:

Inline image 3

' A user-defined type to store the window dimensions.

Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

' Test which version of VBA you are using.

#If VBA7 Then
   ' API function to locate a window.
   Declare PtrSafe Function FindWindow Lib "user32" _
      Alias "FindWindowA" ( _
      ByVal lpClassName As String, _
      ByVal lpWindowName As String) As LongPtr
    
   ' API function to retrieve a window's dimensions.
   Declare PtrSafe Function GetWindowRect Lib "user32" ( _
      ByVal hwnd As LongPtr, _
      lpRect As RECT) As Long

#Else
   ' API function to locate a window.
   Declare Function FindWindow Lib "user32" _
      Alias "FindWindowA" ( _
      ByVal lpClassName As String, _
      ByVal lpWindowName As String) As Long
    
   ' API function to retrieve a window's dimensions.
   Declare Function GetWindowRect Lib "user32" ( _
      ByVal hwnd As Long, _
      lpRect As RECT) As Long
#End If

Sub DisplayExcelWindowSize()
   Dim hwnd As Long, uRect As RECT
   
   ' Get the handle identifier of the main Excel window.
   hwnd = FindWindow("XLMAIN", Application.Caption)
   
   ' Get the window's dimensions into the RECT UDT.
   GetWindowRect hwnd, uRect
   
   ' Display the result.
   MsgBox "The Excel window has these dimensions:" & _
      vbCrLf & " Left: " & uRect.Left & _
      vbCrLf & " Right: " & uRect.Right & _
      vbCrLf & " Top: " & uRect.Top & _
      vbCrLf & " Bottom: " & uRect.Bottom & _
      vbCrLf & " Width: " & (uRect.Right - uRect.Left) & _
      vbCrLf & " Height: " & (uRect.Bottom - uRect.Top)
   
End Sub

Reference:


André Luiz Bernardes


Tags: VBA, Office, API, 32 Bits, 64 Bits, compatibilidade, VBA 6.0, VBA 7.0, MS Office 2003, MS Office 2007, MS Office 2010, MS Office 2010 32 Bits, MS Office 2010 64 Bits,  32-bit (x86), 64-bit (x64)

VBA Excel - DashMap Análise Brasil - Dashboard Brazil analyse

Inline image 1 

Criar Dashboards funcionais e aplicáveis, com um implementação relativamente rápida é possível?


Sem dúvida é o sonho da maioria dos gerentes de departamentos que vêem-se expostos a analisar grandes bases de dados para subsidiar outras áreas. 


Tais gestores inúmeras vezes precisam apresentar resultados em reuniões regulares. Também é um sonho para o analista de TI, e todo bom conhecedor de VBA (Visual Basic for Applications).

Imagine que esta solução esteja ao seu alcance ali mesmo no seu MS Excel, sem a necessidade de adquirir alguma solução de terceiros. 

Essa solução pode assimilar fontes de dados dinâmicas. Ahhh...essa eu quero prá mim!

Pois então, aí está, sirvam-se: 

Veja todo o artigo aqui: 


Bernardes_Brasil_An%C3%A1lise05.png


No exemplo acima as opções de análise são:

- km2

- População (2010)

- Densidade Demográfica (hab./km²) (2010) 

- PIB (em R$ mil - 2008)

- PIB per capita (em R$ - 2008)

- IDH - Índice de Desenvolvimento Humano (2005)

- Analfabetismo funcional (%) 2010

- Mortalidade infantil (‰ nascimentos 2009)

- Expectativa de Vida (Ambos os sexos 2009)




Reference:

Inspiration:

Tags: VBA, Dashmap, Office, Excel, 

VBA Excel - Documentando Aplicações

Inline image 1
| Blog Office VBA | Blog Excel | Blog Access | 

Você que é desenvolvedor MS Excel, criando MIS, Dashboards,ou BSCs possivelmente tem inúmeras soluções prontas. Mas...Será que todas estão documentadas?

Como poderia agilizar parte desta documentação utilizando um código simples e rápido?

Existem documentadores comerciais por aí, mas com este código a seguir poderá listar todos os seus Códigos, Macros, Módulos e Processos dentro das suas aplicações.

Esse código é prático porque pode acrescentar documentação na sua própria planilha. Se desejar pode mantê-la ali mesmo, talvez escondida, e solicitar que esta seja atualizada todas as vezes que for fechada, por exemplo. Ainda mais, poderá ampliar a análise de outros objetos e classes na aplicação.

Crie um novo módulo, talvez com o nome de 'mdl_x_DocApplication' e cole nele o código abaixo:


CÓDIGO:


'=============================================================================================
' Microsoft® Office Excel - DashBoard®, Developed by A&A - In Any Place®.
'
' CopyLeft© A&A - In Any Place, all Lefts Reserved.
'
' Cheque se existe referência ao "Microsoft Visual Basic for Applications Extensibility x.xx"
'=============================================================================================

Option Explicit

Const vbext_pp_none As Long = 0
Const vbext_pk_Proc As Long = 0

Dim x As Long
Dim objList()

Sub RetProject()
    ' Author:                     Date:               Contact:                 URL:
    ' André Bernardes             22/09/2010 15:26    bernardess@gmail.com https://sites.google.com/site/vbabernardes/blogs
    ' Lista todos os módulos, e processos (functions & procedures) neles.

    Dim oBJCT As Object
    Dim Wb As Workbook
    
    Let x = 2
    
    For Each Wb In Workbooks
        For Each oBJCT In Workbooks(Wb.Name).VBProject.VBComponents

            If Workbooks(Wb.Name).VBProject.Protection = vbext_pp_none Then

                Call LoadRoutines(Wb.Name, oBJCT.Name)

            End If

        Next
    Next

    With Sheets.Add
        Let .[A1].Resize (, 3).Value = Array ("Aplicação", "Módulo", "Processos (Functions & Subs)")
        Let .[A2].Resize (UBound (objList, 2), UBound(objList, 1)).Value = Application.Transpose (objList)

        .Columns("A:C").Columns.AutoFit
    End With
End Sub


Agora só precisará utilizar a SUB que carregará todo o conteúdo da sua aplicação (planilha)


CÓDIGO:


Sub LoadRoutines(nWBook As String, vbCmp As String)
    ' Author:                     Date:               Contact:                 URL:
    ' André Bernardes             23/11/2010 15:28    bernardess@gmail.com https://sites.google.com/site/vbabernardes/blogs
    ' Retorna detalhes para a SUB 'RetProject'.
    ' Listening: .

    Dim vbCode As Object
    Dim StartRow As Long

    On Error Resume Next
    
    Set vbCode = Workbooks(nWBook).VBProject.VBComponents(vbCmp).vbCode
    
    With vbCode
        Let StartLine = .CountOfDeclarationLines + 1

        Do Until StartLine >= .CountOfLines

            ReDim Preserve aList (1 To 3, 1 To x - 1)

            Let aList(1, x - 1) = nWBook
            Let aList(2, x - 1) = vbCmp
            Let aList(3, x - 1) = .ProcOfLine(StartRow, vbext_pk_Proc)
            Let x = x + 1
            Let StartLine = StartRow + .ProcCountLines(.ProcOfLine(StartRow, vbext_pk_Proc), vbext_pk_Proc)

            If Err Then Exit Sub
        Loop
    End With

    Set vbCode = Nothing
End Sub



Reference:

Inspiration:

Tags: VBA, Excel, MIS, Dashboards, BSC, document, documentação,

Assinar: Postagens (Atom)

eBooks VBA na AMAZOM.com.br

LinkWithinBrazilVBAExcelSpecialist

Related Posts Plugin for WordPress, Blogger...

Vitrine