[Resolvido]Compactador Backup

Bom Dia!

Tenho um formulário de Backup que utilizei do Maestro Avelino, entretanto, está funcionando normal, porém, estou enfrentando 03 problemas no meu projeto.

1º - O formulário não habilita a função 7-Zip, pois os computadores aqui na empresa não possuem Winrar, ai tive que mudar o compactador.
2º - O contador não chega a 100% e para apresentando uma Mensagem de Backup Concluído
3º - Apresentando Erro 5 e Erro 2467.

Será que há algo errado na adaptação do meu código?

Código:

Private Sub Form_Open(Cancel As Integer)
'----------------------------------------------------------------------------------
'Verifica a presença do programa 7-Zip
'Grava o caminho na variável strLocalCompactador para ser usado na chamada do programa
'-----------------------------------------------------------------------------------
If Len(Dir(Environ("PROGRAMFILES") & "\7-Zip\7z.exe") & "") > 0 Then
    strLocalCompactador = Environ("PROGRAMFILES")
ElseIf Len(Dir(Environ("PROGRAMFILES") & "\7-Zip\7z.exe") & "") > 0 Then
    strLocalCompactador = Environ("PROGRAMFILES")
Else
    Me!check_compactar.Enabled = False
End If
Me!txOrigem = fncOrigemBackup
Me!txDestino = fncDestinoBackup

'CARREGAR TITULO, SUBTITULO, EMPRESA E VERSÃO
Me.txt_cab_titulo = Nz(DLookup("[Título]", "[Tbl_DESENV_Cadastro_de_Formulários_Desenvolvedor]", "[Formulário]='" & FormName & "'"), "")
Me.txt_cab_subtitulo = Nz(DLookup("[Subtitulo]", "[Tbl_DESENV_Cadastro_de_Formulários_Desenvolvedor]", "[Formulário]='" & FormName & "'"), "")
Me.txt_cab_empresa = Nz(DLookup("[Empresa]", "[Tbl_DESENV_Cadastro_de_Formulários_Desenvolvedor]", "[Formulário]='" & FormName & "'"), "")

'CARREGAR A LEGENDA DO FORMULÁRIO
Me.Caption = Nz(DLookup("[Legenda]", "[Tbl_DESENV_Cadastro_de_Formulários_Desenvolvedor]", "[Formulário]='" & FormName & "'"), "")
End Sub

Private Sub Form_Timer()
'---------------------------------------------------------------------------
'Este código se encontra no evento timer para alimentar a barra de progresso
'---------------------------------------------------------------------------
On Error GoTo trataErro
Evento = Evento + 1
Select Case Evento
    Case 1
        '-------------------------------------------------------------------------
        'Desabilita os botões enquanto a cópia estiver sendo realizada
        'Divide a barra de progresso, que tem um comprimento de 16cm, em 8 pedaços
        '-------------------------------------------------------------------------
        Me!cx1.Visible = True
        Me!btFoco.SetFocus
        Me!btCaminho.Enabled = False
        Me!btIniciarBackup.Enabled = False
        Escala = (16.5 * 690) / 10
        Me!cx1.Width = Escala
        Me!txt_porcentagem.Caption = "2%"
    Case 2
        Set objfs = CreateObject("Scripting.FileSystemObject")
        Me!Status.Caption = "Verificando Base de Dados..."
        Me!cx1.Width = Escala * 2
        Me!txt_porcentagem.Caption = "25%"
    Case 3
        Me!Status.Caption = "Copiando Base de Dados..."
        Me!cx1.Width = Escala * 3
        Me!txt_porcentagem.Caption = "40%"
    Case 4
        '----------------------------------------------------------------------------
        'Inicia o processo de cópia simples da base de dados para o destino indicado.
        'Aqui a barra de progresso fica parada até a cópia ser concluída
        '----------------------------------------------------------------------------
        objfs.CopyFile Me!txOrigem, Me!txDestino
    Case 5
        '----------------------------------------------
        'Após a conclusão da cópia o código prossegue
        '----------------------------------------------
        Me!Status.Caption = "Compactando Base de Dados..."
        Me!cx1.Width = Escala * 4
        Me!txt_porcentagem.Caption = "50%"
    Case 6
        Dim booResultado As Boolean
        '---------------------------------------------------------------------------------
        'Se a sua base de dados contiver uma senha de acesso, o método compactar e reparar
        'irá solicitá-la.
        '
        'A função do SendKeys é passar a senha no processo sem a intervenção do usuário.
        '
        'A função fncProtegido verifica se a base de dados possui senha e então permite
        'o uso do SendKeys.
        '
        'A função fncCapturSenha captura a senha informada na tabela tblCaminhoBe
        '---------------------------------------------------------------------------------
        If fncProtegido = True Then
            Dim objws As Object
            Set objws = CreateObject("wscript.shell")
          '-------------------------------------------------------------------------------------------
            'verifica se não há outro programa com o foco, como o word, excel ou o bloco de notas.
            'Enqunto o Access não tiver o foco, fica aguardando
            '------------------------------------------------------------------------------------------
            Do While GetFocus <> Me.hWnd
                Call Sleep(500) 'aguarda por meio segundo
                DoEvents '
            Loop
            '-------------------------------------------------------------------------------------------
            objws.SendKeys fncCapturaSenha, True
            objws.SendKeys "{ENTER}"
        End If
        Me!cx1.Width = Escala * 5
        Me!txt_porcentagem.Caption = "60%"
        '-----------------------------------------------------------------------
        'Observe que está sendo compactado e reparado a copia que foi gerada
        'pelo objfs.CopyFile no destino.
        '
        'É gerado então um outro arquivo, devidamente compactado e reparado, no
        'mesmo local de destino.
        '-----------------------------------------------------------------------
        DestinoNovo = Replace(Me!txDestino, "-", "-c")
        booResultado = Application.CompactRepair(Me!txDestino, DestinoNovo, True)
        '-----------------------------------------------------------------------------
        'O arquivo que foi copiado para o destino, pelo objfs.CopyFile, será excluído,
        'pois só nos interessa o que foi compactado e reparado.
        '-----------------------------------------------------------------------------
        If booResultado = True Then FileSystem.Kill Me!txDestino
        Set objws = Nothing
        Me!cx1.Width = Escala * 6
        Me!txt_porcentagem.Caption = "70%"
    Case 7
        '-------------------------------------------------
        'Executa o 7-Zip oculto se este tiver habilitado
        '--------------------------------------------------
        If Me!check_compactar = True Then
            Me!Status.Caption = "Compactando com o 7-Zip..."
            Dim compri
            compri = Shell(strLocalCompactador & "\7-Zip\7z.exe a " & Chr(34) & Replace(DestinoNovo, ".accdb", "") & ".zip" & Chr(34) & " " & Chr(34) & DestinoNovo & Chr(34), vbHide)
        End If
        Me!cx1.Width = Escala * 7
        Me!txt_porcentagem.Caption = "75%"
    Case 8
        If Me!check_compactar = True Then
        Me!cx1.Width = Escala * 8
        Me!txt_porcentagem.Caption = "80%"
            '--------------------------------------------------------------------------
            'Enquanto o 7-Zip não completar a tarefa de compactação, o comprimento
            'do arquivo gerado fica em zero. Verifico este comprimento com o FileLen.
            'A barra de progresso vai crescendo gradativamente enquanto o 7-Zip não
            'concluir a tarefa.
            '--------------------------------------------------------------------------
            If FileSystem.FileLen((Replace(DestinoNovo, ".accdb", "") & ".zip ")) = 0 Then
                Evento = 7
                If Me!cx1.Width < (11.2 * 690) Then intCont = intCont + 1
                Me!cx1.Width = (Escala * 9) + (15 * intCont)
                Me!txt_porcentagem.Caption = "90%"
            Else
                '----------------------------------------------------
                'Deleto o arquivo que não foi compactado pelo 7-Zip
                '----------------------------------------------------
                FileSystem.Kill DestinoNovo
                Me!Status.Caption = "Backup Concluído..."
                Screen.MousePointer = 0
                Me!cx1.Width = Escala * 10
                Me.TimerInterval = 3000
                Me!txt_porcentagem.Caption = "100%"
                MsgBox "Backup Concluído...", vbOKOnly + vbExclamation, "BACKUP"
            End If
        Else
            Me!Status.Caption = "Backup Concluído..."
            Screen.MousePointer = 0
            Me!cx1.Width = Escala * 10
            Me.TimerInterval = 3000
            Me!txt_porcentagem.Caption = "100%"
            MsgBox "Backup Concluído...", vbOKOnly + vbExclamation, "BACKUP"

        End If
    Case 9
        Set objfs = Nothing
        '-------------------------------------------------------------------------------------
        'Caso tenha ocorrido uma correção da base de dados, pelo método compactar e reparar
        'é gerado um arquilo de log.
        '
        'Então abre um comunicado, para chamada urgente do adminitrador, que deverá verificar
        'e corrigir a base de dados em uso.
        '-------------------------------------------------------------------------------------
        If Len(Dir(left(Me!txDestino, InStrRev(Me!txDestino, "\")) & "*.log", vbArchive) & "") > 0 Then
            MsgBox "Foi detectado problemas no arquivo de Backup." & vbCrLf & _
            vbCrLf & "Entre em contato imediatamente com o Desenvolvedor do Banco de Dados.", vbCritical, "Aviso"
        End If
        Me.TimerInterval = 0
        Evento = 0
End Select

sair:
    If Me.TimerInterval = 0 Then DoCmd.Close acDefault
    Exit Sub
trataErro:
    MsgBox err.Number & " - " & err.Description, vbInformation, "Aviso"
    Evento = 0: Screen.MousePointer = 0: Me.TimerInterval = 0
    Resume sair
End Sub

Agradeço desde já a ajuda e atenção.

Boa tarde Maurício Bruno, eu utilizo o mesmo script e da forma que você usou também com 7-zip, único problema que observei em comparação com o meu é que você não especificou no primeiro If  o caminho correto vide anotações ao lado do bloco

Por exemplo:

'Lembre-se que o 7-zip pode estar instalado na pasta ProgramFiles(x86), verifique, acho que seu caminho está errado

Código:

Private Sub Form_Open(Cancel As Integer)
'----------------------------------------------------------------------------------
'Verifica a presença do programa 7-Zip
'Grava o caminho na variável strLocalCompactador para ser usado na chamada do programa
'-----------------------------------------------------------------------------------
If Len(Dir(Environ("ProgramFiles(x86)") & "\7-Zip\7z.exe") & "") > 0 Then  'Observe o caminho que encontra o programa. Aqui também procuro na ProgramFiles(x86) em vez da ProgramFiles
    strLocalCompactador = Environ("ProgramFiles(x86)") 'Aqui recebe ProgramFiles(x86) também

'Ai se não tiver na X86 ai procuro na ProgramFiles somente

ElseIf Len(Dir(Environ("ProgramFiles") & "\7-Zip\7z.exe") & "") > 0 Then
    strLocalCompactador = Environ("ProgramFiles")
Else
    Me!check_compactar.Enabled = False
End If


Verifica ai e posta o resultado

Boa noite, Maurício Bruno
Leia e siga as regras, de forma a manter o fórum organizado
Eliminei-lhe o outro tema por se tratar de repetição desta dúvida

daygdson,

Primeiramente agradeço a atenção e ajuda, mais não habilitou o campo do checkbox do 7-zip ainda, segue o projeto em anexo.

Código:

Private Sub Form_Open(Cancel As Integer)
'----------------------------------------------------------------------------------
'Verifica a presença do programa 7-Zip
'Grava o caminho na variável strLocalCompactador para ser usado na chamada do programa
'-----------------------------------------------------------------------------------
If Len(Dir(Environ("ProgramFiles(x86)") & "\7-Zip\7z.exe") & "") > 0 Then
    strLocalCompactador = Environ("ProgramFiles(x86)")
ElseIf Len(Dir(Environ("ProgramFiles") & "\7-Zip\7z.exe") & "") > 0 Then
    strLocalCompactador = Environ("ProgramFiles")
Else
    Me!check_compactar.Enabled = False
End If
Me!txOrigem = fncOrigemBackup
Me!txDestino = fncDestinoBackup

'CARREGAR TITULO, SUBTITULO, EMPRESA E VERSÃO
Me.txt_cab_titulo = Nz(DLookup("[Título]", "[Tbl_DESENV_Cadastro_de_Formulários_Desenvolvedor]", "[Formulário]='" & FormName & "'"), "")
Me.txt_cab_subtitulo = Nz(DLookup("[Subtitulo]", "[Tbl_DESENV_Cadastro_de_Formulários_Desenvolvedor]", "[Formulário]='" & FormName & "'"), "")
Me.txt_cab_empresa = Nz(DLookup("[Empresa]", "[Tbl_DESENV_Cadastro_de_Formulários_Desenvolvedor]", "[Formulário]='" & FormName & "'"), "")

'CARREGAR A LEGENDA DO FORMULÁRIO
Me.Caption = Nz(DLookup("[Legenda]", "[Tbl_DESENV_Cadastro_de_Formulários_Desenvolvedor]", "[Formulário]='" & FormName & "'"), "")
End Sub

Private Sub Form_Timer()
'---------------------------------------------------------------------------
'Este código se encontra no evento timer para alimentar a barra de progresso
'---------------------------------------------------------------------------
On Error GoTo trataErro
Evento = Evento + 1
Select Case Evento
    Case 1
        '-------------------------------------------------------------------------
        'Desabilita os botões enquanto a cópia estiver sendo realizada
        'Divide a barra de progresso, que tem um comprimento de 16cm, em 8 pedaços
        '-------------------------------------------------------------------------
        Me!cx1.Visible = True
        Me!btFoco.SetFocus
        Me!btCaminho.Enabled = False
        Me!btIniciarBackup.Enabled = False
        Escala = (16.5 * 690) / 10
        Me!cx1.Width = Escala
        Me!txt_porcentagem.Caption = "2%"
    Case 2
        Set objfs = CreateObject("Scripting.FileSystemObject")
        Me!Status.Caption = "Verificando Base de Dados..."
        Me!cx1.Width = Escala * 2
        Me!txt_porcentagem.Caption = "25%"
    Case 3
        Me!Status.Caption = "Copiando Base de Dados..."
        Me!cx1.Width = Escala * 3
        Me!txt_porcentagem.Caption = "40%"
    Case 4
        '----------------------------------------------------------------------------
        'Inicia o processo de cópia simples da base de dados para o destino indicado.
        'Aqui a barra de progresso fica parada até a cópia ser concluída
        '----------------------------------------------------------------------------
        objfs.CopyFile Me!txOrigem, Me!txDestino
    Case 5
        '----------------------------------------------
        'Após a conclusão da cópia o código prossegue
        '----------------------------------------------
        Me!Status.Caption = "Compactando Base de Dados..."
        Me!cx1.Width = Escala * 4
        Me!txt_porcentagem.Caption = "50%"
    Case 6
        Dim booResultado As Boolean
        '---------------------------------------------------------------------------------
        'Se a sua base de dados contiver uma senha de acesso, o método compactar e reparar
        'irá solicitá-la.
        '
        'A função do SendKeys é passar a senha no processo sem a intervenção do usuário.
        '
        'A função fncProtegido verifica se a base de dados possui senha e então permite
        'o uso do SendKeys.
        '
        'A função fncCapturSenha captura a senha informada na tabela tblCaminhoBe
        '---------------------------------------------------------------------------------
        If fncProtegido = True Then
            Dim objws As Object
            Set objws = CreateObject("wscript.shell")
           '-------------------------------------------------------------------------------------------
            'verifica se não há outro programa com o foco, como o word, excel ou o bloco de notas.
            'Enqunto o Access não tiver o foco, fica aguardando
            '------------------------------------------------------------------------------------------
            Do While GetFocus <> Me.hWnd
                Call Sleep(500) 'aguarda por meio segundo
                DoEvents '
            Loop
            '-------------------------------------------------------------------------------------------
            objws.SendKeys fncCapturaSenha, True
            objws.SendKeys "{ENTER}"
        End If
        Me!cx1.Width = Escala * 5
        Me!txt_porcentagem.Caption = "60%"
        '-----------------------------------------------------------------------
        'Observe que está sendo compactado e reparado a copia que foi gerada
        'pelo objfs.CopyFile no destino.
        '
        'É gerado então um outro arquivo, devidamente compactado e reparado, no
        'mesmo local de destino.
        '-----------------------------------------------------------------------
        DestinoNovo = Replace(Me!txDestino, "-", "-c")
        booResultado = Application.CompactRepair(Me!txDestino, DestinoNovo, True)
        '-----------------------------------------------------------------------------
        'O arquivo que foi copiado para o destino, pelo objfs.CopyFile, será excluído,
        'pois só nos interessa o que foi compactado e reparado.
        '-----------------------------------------------------------------------------
        If booResultado = True Then FileSystem.Kill Me!txDestino
        Set objws = Nothing
        Me!cx1.Width = Escala * 6
        Me!txt_porcentagem.Caption = "70%"
    Case 7
        '-------------------------------------------------
        'Executa o 7-Zip oculto se este tiver habilitado
        '--------------------------------------------------
        If Me!check_compactar = True Then
            Me!Status.Caption = "Compactando com o 7-Zip..."
            Dim compri
            compri = Shell(strLocalCompactador & "\7-Zip\7z.exe a " & Chr(34) & Replace(DestinoNovo, ".accdb", "") & ".zip" & Chr(34) & " " & Chr(34) & DestinoNovo & Chr(34), vbHide)
        End If
        Me!cx1.Width = Escala * 7
        Me!txt_porcentagem.Caption = "75%"
    Case 8
        If Me!check_compactar = True Then
        Me!cx1.Width = Escala * 8
        Me!txt_porcentagem.Caption = "80%"
            '--------------------------------------------------------------------------
            'Enquanto o 7-Zip não completar a tarefa de compactação, o comprimento
            'do arquivo gerado fica em zero. Verifico este comprimento com o FileLen.
            'A barra de progresso vai crescendo gradativamente enquanto o 7-Zip não
            'concluir a tarefa.
            '--------------------------------------------------------------------------
            If FileSystem.FileLen((Replace(DestinoNovo, ".accdb", "") & ".zip ")) = 0 Then
                Evento = 7
                If Me!cx1.Width < (11.2 * 690) Then intCont = intCont + 1
                Me!cx1.Width = (Escala * 9) + (15 * intCont)
                Me!txt_porcentagem.Caption = "90%"
            Else
                '----------------------------------------------------
                'Deleto o arquivo que não foi compactado pelo 7-Zip
                '----------------------------------------------------
                FileSystem.Kill DestinoNovo
                Me!Status.Caption = "Backup Concluído..."
                Screen.MousePointer = 0
                Me!cx1.Width = Escala * 10
                Me.TimerInterval = 3000
                Me!txt_porcentagem.Caption = "100%"
                MsgBox "Backup Concluído...", vbOKOnly + vbExclamation, "BACKUP"
            End If
        Else
            Me!Status.Caption = "Backup Concluído..."
            Screen.MousePointer = 0
            Me!cx1.Width = Escala * 10
            Me.TimerInterval = 3000
            Me!txt_porcentagem.Caption = "100%"
            MsgBox "Backup Concluído...", vbOKOnly + vbExclamation, "BACKUP"

        End If
    Case 9
        Set objfs = Nothing
        '-------------------------------------------------------------------------------------
        'Caso tenha ocorrido uma correção da base de dados, pelo método compactar e reparar
        'é gerado um arquilo de log.
        '
        'Então abre um comunicado, para chamada urgente do adminitrador, que deverá verificar
        'e corrigir a base de dados em uso.
        '-------------------------------------------------------------------------------------
        If Len(Dir(left(Me!txDestino, InStrRev(Me!txDestino, "\")) & "*.log", vbArchive) & "") > 0 Then
            MsgBox "Foi detectado problemas no arquivo de Backup." & vbCrLf & _
            vbCrLf & "Entre em contato imediatamente com o Desenvolvedor do Banco de Dados.", vbCritical, "Aviso"
        End If
        Me.TimerInterval = 0
        Evento = 0
End Select

sair:
    If Me.TimerInterval = 0 Then
    DoCmd.Close acDefault
    End If
    Exit Sub
trataErro:
    MsgBox err.Number & " - " & err.Description, vbInformation, "Aviso"
    Evento = 0: Screen.MousePointer = 0: Me.TimerInterval = 0
    Resume sair
End Sub

Grato,

Caro Maurício Bruno, baixei o seu projeto, e era exatamente o erro que tinha informado pra você, no seu script não estava o caminho do ProgramFiles(x86) especificado, a não ser que seu 7-zip esteja instalado em outro diretório, dá uma olhadinha ai na alteração que fiz. Outra coisa mudei a função de origem , tirei Dlookup e mudei para Application.CurrentProject, Vê ai e posta o resultado.

daygdson,

O meu caso esta na segunda opção que seria esta parte do código, entretanto, continua não habilitando.

Código:

ElseIf Len(Dir(Environ("ProgramFiles") & "\7-Zip\7z.exe") & "") > 0

Obrigado.

Bom, neste caso o seu 7-zip deve ser de 64bits, aqui eu tenho instalado o de 32 bits por isso ele fica na pasta ProgramFiles(x86). Ele só não está habilitado porque não está encontrando o diretório de execução do 7-zip. Verifica o caminho conforme disse anteriormente, ou desinstala e instala novamente e observe o caminho de instalação.

No aguardo

daygdson,

Desinstalei e reinstalei e ficou no caminho abaixo.

Meu Computador e 64 Bits.

C:\Program Files\7-Zip\7z.exe

E mesmo assim não funcionou.

Grato

Cara, acabei de desinstalar o 7-zip 32 e instalei o de 64bits no caminho c:\ProgramFiles\7-zip e funcionou certinho, gerou o backup compactado normalmente, será que não está bloqueado a pasta ProgramFiles, verifica a permissão de leitura e execução na central de confiabilidade dá sua base de dados, se não me engano vc vai ter que dar permissão para executar macros neste diretório para o sistema ter acesso ao 7-zip

Deu certo.

Muito Obrigado!

O Fórum agradece seu retorno.