[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?

Boa tarde ahteixeira

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

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

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

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

Obrigado ahteixeira

O Erro era aquele mesmo da data e da hora.

Muito obrigado funcionou

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