Public Sub Back_Up()
Dim Wisso As String
Wisso = Nz(DLookup("Database", "MSysObjects", "Type=6"), CurrentProject.fullname)
On Error GoTo MyErr
If Len(Dir(CurrentProject.Path & "/" & "Backup", vbDirectory)) = 0 Then
    MkDir CurrentProject.Path & "/" & "Backup"
End If
Dim OldFile, DBwithEXT, DBwithoutEXT, newfile, copymydb
OldFile = Wisso
DBwithEXT = Dir(OldFile)
DBwithoutEXT = Left(DBwithEXT, Len(DBwithEXT) - 4)
newfile = CurrentProject.Path & "\Backup\base" & "-" & Format(date, "yyyy-mm-dd") & "-" & Format(Now(), "Hh-Nn.") & "accdb"
copymydb = "cmd.exe /C copy " & """" & OldFile & """" & " " & """" & newfile & """"
Shell copymydb, 0
    'MsgBox "     ", vbInformation, ""
Exit Sub
MyErr:
If Err.Number = 76 Then
    MsgBox "            ", , ""
ElseIf Err.Number <> 0 Then
   MsgBox "          ", , ""
End If
End Sub
