[Resolvido]Backup de mdb com data

Cole as funções abaixo em um módulo global

Option Compare Database
Option Explicit

Public Sub ZipaBanco()
'Criado pelo colega Raw do Canadá
'Adaptado por JPaulo ® Maximo Access
'Adaptado por Norberto Rost
    Dim strDate As String, DefPath As String
    Dim oApp As Object
    Dim fname, FileNameZip
    'Dim strPrefix As String
    On Error Resume Next
    'No argumento defina uma pasta definida na lista da função
    'As opções de pasta são definidas na função
    DefPath = fncOrigem(mSystem) 'pasta de destino do backup
        If Right(DefPath, 1) <> "\" Then
            DefPath = DefPath & "\"
        End If

    strDate = Format(Now, "dd-mmm-yy_h-mm-ss")
    FileNameZip = DefPath & Empresa & " Backup " & Format(Date, "Long Date") & " .zip"
    fname = BackEndAtual
    On Error Resume Next
    CriaNovoZip (FileNameZip)
    Set oApp = CreateObject("Shell.Application")
    oApp.NameSpace(FileNameZip).CopyHere fname
    Info "Criado com sucesso em: " & FileNameZip
    Set oApp = Nothing
    Exit Sub
End Sub

Public Sub CriaNovoZip(sPath)
'Criado pelo colega Raw do Canadá
'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


No seu botão (ou comando de menu) é só chamar:
(Esta parte não fica no módulo global)

Private Sub NomeBotão_Click()
  Call ZipaBanco
End Sub

Função para Identificação da Empresa (é incluída no nome do arquivo de backup):

Public Function Empresa() As String
    Empresa = "Nome da Empresa"
End Function

Função que permite escolher pastas para o backup e outros fins:

'Código de Avelino Sampaio
'Cria uma lista para usar com o argumento pasta
'Cada item corresponde a número começando do zero
'
Public Enum mPasta
  mRaiz
  mSystem
  mImagens
End Enum

Public Function fncOrigem(Optional pasta As mPasta = mRaiz)
On Error Resume Next
  Dim strLocal As String
    Select Case pasta
      'Crie aqui a sua estrutura de pastas
      Case 0: strLocal = "\"
      Case 1: strLocal = "\System\"
      Case 2: strLocal = "\Imagens\"
      Case Else: MsgBox "Pasta informada fora da lista...", vbInformation, "Aviso"
  End Select
fncOrigem = Application.CurrentProject.Path & strLocal
End Function

Função que Retorna o arquivo backend:

Public Function BackEndAtual() As String
  Dim strCon As String
  ' tab_Clientes é um exemplo. Substitua pelo nome de uma tabela qualquer do backend
  strCon = CurrentDb.TableDefs("tab_Clientes").Connect
  BackEndAtual = Right$(strCon, Len(strCon) - InStr(1, strCon, "=", 2))
End Function