[Resolvido]Código para Backup Zipado

Boa Tarde.

Em busca de um código para fazer backup, copiei um criado pelo mestre JPaulo, faz tudo corretamente, ele cria o arquivo zipado na pasta onde direcionei, mas não copia o banco de dados, o arquivo fica vazio.
Alguem sabe por que?
Sera porque tem maquinas na rede ainda logado no banco de dados?
Ou isto não tem nada a ver?

Segue abixo o código como ficou.

Código:

Option Compare Database
Option Explicit

Public Sub ZipaBanco()
Dim strDate As String, DefPath As String
Dim oApp As Object
Dim FName, FileNameZip As String
Dim strPrefix As String
On Error Resume Next

'Caminho da pasta onde vai ser feito o backup
DefPath = "D:\Sistema_Consulta_Produtos\Backup"
If Right(DefPath, 1) <> "\" Then
DefPath = DefPath & "\"
    End If
   
    strDate = Format(Now, "dd-mmm-yyyy_H-mm-ss")
    FileNameZip = DefPath & "Backup_" & strDate & ".Zip"
   
    strPrefix = "Pecas_Diseg_be.accdb"
   
    'Caminho do Back End
   
    FName = "D:\Sistema_Consulta_Produtos\" & strPrefix & ".accdb"
    On Error Resume Next
    CriaNovoZip (FileNameZip)
    Set oApp = CreateObject("Shell.Application")
    oApp.NameSpace(FileNameZip).CopyHere FName
    Call MsgBox("Backup Criado com Sucesso em: " & FileNameZip, vbInformation, "Criação de Backup Zipado")
    Set oApp = Nothing
   
    Exit Sub
   
End Sub
----------------------------------------------------------------------------------------------------------------------------------------

Public Sub CriaNovoZip(sPath)
    Dim ofso, arrHex, sBin, i, Zip
    On Error Resume Next
    Set ofso = CreateObject("Scripting.FileSystemObject")
    arrHex = Array(80, 75, 5, 6, 0, 0, 0, _
                  0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0)
    For i = 0 To UBound(arrHex)
        sBin = sBin & Chr(arrHex(i))
    Next
    On Error Resume Next
    With ofso.CreateTextFile(sPath, True)
        .Write sBin
        .Close
    End With
  Exit Sub
End Sub

Desde ja Agradeço.

Boa tarde

Testei com as outras maquinas desligadas, e com o sisteama fechado
Ficou do mesmo jeito, cria o arquivo zipado sem o banco de dados.

Alguem sabe por que?

Olá, teste alterando a linha:
strPrefix = "Pecas_Diseg_be.accdb"
Para:
strPrefix = "Pecas_Diseg_be"

Abraço

Boa tarde ahteixeira

Muito Obrigado pelo retorno
Modifiquei a linha conforme sua orientação, mas infelizmente nem o arquivo agora ele cria na pasta.

e como faz pra zipar com senha

Boa tarde NadirONunes

Veja o link abaixo, um exemplo excelente criado pelo Piloto

http://maximoaccess.forumeiros.com/t13490-restauracao-de-backup-com-desconexao-de-usuarios-logados-na-rede?highlight=Backup+de+bd+accdb

Olá,
Descompacte para o disco c:\
e teste o exemplo, depois é só alterar os caminhos e nome da base de dados.
Abraço

ele nao zipa com senha, eu quero que ele faz um backup com senha

Ola, com senha desconheço desta forma.
Utilize winrar, 7zip.
Com uma busca aqui no fórum tem exemplos como fazer.
Abraço

Bom dia ahteixeira

Muito Obrigado pela atenção

Copiei o script do exemplo que vc me mandou para um modulo que criei no meu próprio sistema do jeito que você me orientou alterando o código e adptando ao meu sistema.
Criei um botão onde coloquei Fazer Backup, e na propriedade evento ao clica digitei "Call ZipaBanco"
Ao acionar o botão Fazer Backup ele me da a mensagem de Backup criado com sucesso na pasta indicada e tudo mais.
Só que não ta criando o arquivo na pasta.
Veja como ficou o código novamente.

Código:

Option Compare Database
Option Explicit


Public Sub ZipaBanco()
'JPaulo ? Maximo Access
'http://maximoaccess.forumeiros.com/t16321-resolvidoenviar-arquivo-zipado-por-e-mail-no-mesmo-evento

Dim strDate As String, DefPath As String
Dim oApp As Object
Dim FName, FileNameZip
Dim strPrefix As String
On Error Resume Next

    DefPath = Application.CurrentProject.Path & "\" & "Backup" 'Caminho da pasta onde esta o banco a zipar
    
    'verifica se existe pasta destino
    If Len(Dir(DefPath, vbDirectory) & "") = 0 Then
        MsgBox "Não existe caminho para backup: " & DefPath
        Exit Sub
    End If
    
    If Right(DefPath, 1) <> "\" Then
        DefPath = DefPath & "\"
    End If

    strDate = Format(Now, "dd/mmmm/yyyy - hh:mm:ss")
    FileNameZip = DefPath & "Backup_" & strDate & ".zip"

    strPrefix = "Pecas_Diseg_be" 'Nome do banco que vai ser zipado


    'FName ? o caminho da pasta onde vai ficar o banco zipado.
    'neste exemplo vai ficar junto ao proprio banco
    'Se o seu Ms Access for anterior ao 2007,
    'deve alterar a exten??o de .accdb para .mdb
    FName = Application.CurrentProject.Path & "\" & strPrefix & ".accdb"

    'verifica se existe ficheiro
    If Len(Dir(FName) & "") = 0 Then
        MsgBox "Não existe o Banco de Dados: " & FName
        Exit Sub
    End If
 

    On Error Resume Next
    CriaNovoZip (FileNameZip)
    Set oApp = CreateObject("Shell.Application")
    oApp.NameSpace(FileNameZip).CopyHere FName
    MsgBox "Backup Criado com Sucesso em: " & FileNameZip
    Set oApp = Nothing
    Exit Sub
End Sub


Public Sub CriaNovoZip(sPath)
'Criado pelo meu amigo e colega Raw do Canada
'Adaptado por JPaulo ? Maximo Access
Dim ofso, arrHex, sBin, i, Zip
On Error Resume Next
Set ofso = CreateObject("Scripting.FileSystemObject")
arrHex = Array(80, 75, 5, 6, 0, 0, 0, _
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0)
For i = 0 To UBound(arrHex)
sBin = sBin & Chr(arrHex(i))
Next
On Error Resume Next
With ofso.CreateTextFile(sPath, True)
.Write sBin
.Close
End With
Exit Sub
End Sub


Desde ja Agradeço

Olá,

Para ajudar, será melhor dizer qual o erro para isso será necessário colocar a plica onde tiver:

Código:

On Error Resume Next

colocar:

Código:

'On Error Resume Next

Depois teste e em caso de erro tome nota do mesmo para reportar.
Também necessitamos que informe:

1) Indique o caminho completo e nome de ficheiro + extenção
 exemplo:   C:\MinhaPastaPrograma\MinhaBasedeDados.accdb

2) Indique o caminho destino
exemplo: D:\Backups\BaseDados

Abraço

Bom hteixeira

o erro que apareceu é este:

Erro em tempo de execução '91':
A variavel do objeto ou a variavel do bloco 'whit' não foi definida.

e esta linha aparece selecionada de amarelo:
oApp.NameSpace(FileNameZip).CopyHere FName

Não sei se faz diferença mas uso o aoffice 2013

Caminho do banco de dados:
D:\Sistema_Consulta_Produtos\Pecas_Diseg_be

Caminho Destino:
D:\Sistema_Consulta_Produtos\Backup

No casa Backup é uma pasta

Desde ja Agradeço

Olá Samuel,

O meu exemplo testei em 2013 64 e windows 7 64 e está a funfar (nem é necessária nenhuma alteração).

Agora diga-me, quando alterou o seguinte código o que aconteceu a seguir???

Código:

strDate = Format(Now, "dd/mmmm/yyyy - hh:mm:ss")

Deve ter dado erro, acho que assim fica bem:

Código:

strDate = Format(Now, "yyyymmdd_hhmmss")

O sistema não consegue criar ficheiros com : no nome

Abraço

Obrigado ahteixeira

O Erro era aquele mesmo da data e da hora.

Muito obrigado funcionou

Olá Samuel, obrigado pelo retorno os utilizadores do fórum agradecem.
Abraço

Boa tarde. Mais nenhum dos dois tem senha, então a integridade a rouba dos dados pode ser feita