[Resolvido]Zipar Banco

Public Sub ZipaBanco()
'JPaulo ® Maximo Access
   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 'Local e pasta onde está o banco para backup
   If Right(DefPath, 1) <> "\" Then
       DefPath = DefPath & "\"
   End If

   strDate = Format(Now, "dd-mmmm-yyyy_hh-mm")
   FileNameZip = DefPath & "Backup_" & strDate & ".zip"
   strPrefix = "ZiparBd" 'Nome do banco
   FName = Application.CurrentProject.Path & "\" & strPrefix & ".accdb"
       On Error Resume Next
   CriaNovoZip (FileNameZip)
   Set oApp = CreateObject("Shell.Application")
   oApp.NameSpace(FileNameZip).CopyHere FName
   MsgBox "Criado com Sucesso em: " & FileNameZip
   Set oApp = Nothing
  Exit Sub
End Sub

Public Sub CriaNovoZip(sPath)
'Criado pelo meu amigo e 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