Public Sub Backupme()

On Error GoTo MyErr

Dim OldFile, NewFile, CopyMyDB, wheretoBackup, BackupFolder, DBName As String

    If IsNull(DLookup("Database", "MSysObjects", "Type=6")) Then
        OldFile = CurrentProject.fullname
        wheretoBackup = CurrentProject.Path
    Else
        OldFile = DLookup("Database", "MSysObjects", "Type=6")
        wheretoBackup = Left(OldFile, InStrRev(OldFile, "\"))
    End If

    BackupFolder = wheretoBackup & "\Backup"

On Error Resume Next
If Len(Dir(BackupFolder)) = 0 Then
    MkDir BackupFolder
    Else
    End If
On Error GoTo MyErr

    DBName = Left(CurrentProject.name, InStrRev(CurrentProject.name, ".") - 1)

NewFile = wheretoBackup & "\Backup\" & DBName & "-Base_Backup-" & Format(date, "dd-mm-yyyy") & "-" & Format(Now(), "Hh-Nn.") & Right(OldFile, 5)
CopyMyDB = "cmd.exe /C copy " & """" & OldFile & """" & " " & """" & NewFile & """"
Shell CopyMyDB, 0


'MsgBox "Backup..Done" & vbNewLine & vbNewLine & "Saved in :" & vbNewLine & NewFile, , " "

MyErr:
If Err.Number <> 0 Then
'MsgBox Err.Number & " - " & Err.Description
End If

End Sub
