Help backing up a database that is stored on a USB drive (1 Viewer)

Private Sub Button_Backup_Click()
Dim str As String
Dim buf As String
Dim MD_Date As Variant
Dim fs As Object
Dim source As String
Const conPATH_FILE_ACCESS_ERROR = 75
On Error GoTo Backup_Button_Backup
'buf = Back Up Folder
'buf is created if it does not exist
'CurrentProject.Path = F:\Access Quoting\Back End
buf = CurrentProject.Path & "\Backups\"
MkDir buf
    Resume Backup_Button_Backup
Backup_Button_Backup:
'Use yyyy-mm-dd hh-mm-ss as folder name. Change as needed.
MD_Date = Format(Date, "yyyy.mm.dd ") & Format(Time, "- hh.mm")
str = CurrentProject.Path & "\Backups\" & MD_Date
'Source = where the data is stored
source = CurrentProject.Path & "\Back End\"
MkDir str
Set fs = CreateObject("Scripting.FileSystemObject")
'Change the file extension as needed
fs.CopyFile source & "*.accdb", str
Set fs = Nothing
MsgBox "Access Quoting database backup  " & vbCrLf & MD_Date & vbCrLf & "Completed successfully! Press Ok to close", _
        vbInformation, "Backup Successful"
Exit_Button_Backup:
    DoCmd.Quit
  Exit Sub
Err_Button_Backup:
  If Err.Number = conPATH_FILE_ACCESS_ERROR Then
    MsgBox "The following Path, " & str & ", already exists or there was an Error " & _
           "accessing it!", vbExclamation, "Path/File Access Error"
  Else
    MsgBox Err.Description, vbExclamation, "Error Creating " & str
  
End If
    Resume Exit_Button_Backup
End Sub

Public Function BackupSource()

'******************************************************************************
'                                                                             *
'Author: Unknown                                                              *
'Modified By: Adam Evanovich                                                  *
'Date: 9/25/2010                                                              *
'Purpose: To backup the source BackEnd file of a database                     *
'                                                                             *
'Arguments: None                                                              *
'                                                                             *
'******************************************************************************

On Error GoTo Err_BackupSource

Dim strBu As String
   Dim buf As String
      Dim MD_Date As Variant
         Dim fs As Object
            Dim strSourceName As String
               Dim strSourceFile As String

                  Const conPATH_FILE_ACCESS_ERROR = 75

strSourceName = CurrentProject.Name
strSourceFile = CurrentProject.Path
buf = CurrentProject.Path & "\Backups\"

   If GetAttr(buf) <> vbDirectory Then
      MkDir buf
   End If

Continue:

      MD_Date = Format(Date, "yyyy-mm-dd ") & Format(time, "hh-mm-ss")
      strSourceFile = CurrentProject.Path
      strBu = CurrentProject.Path & "\Backups\" & MD_Date & "\"
   
         MkDir (strBu)
         
            Set fs = CreateObject("Scripting.FileSystemObject")
               fs.CopyFile strSourceFile & "\" & strSourceName, strBu
            Set fs = Nothing
 
'Successful
MsgBox "Data backup at " & vbCrLf & MD_Date & vbCrLf & "successful!", _
        vbInformation, "Backup Successful"
 
Exit_BackupSource:
  Exit Function
 
Err_BackupSource:
  If err.Number = conPATH_FILE_ACCESS_ERROR Then
    MsgBox "The following Path, " & strBu & ", already exists or there was an Error " & _
           "accessing it!", vbExclamation, "Path/File Access Error"
  Else
      If err.Number = 53 Then
         MkDir buf
            GoTo Continue
      Else
         MsgBox err.Description, vbExclamation, "Error Creating " & strBu
      End If
  End If

End Function '//LL

Sub CreateBackup(Optional strDBType As String)
    Dim strDBpath As String, ext As String, tmp As String
    Dim strPath As String, strBackupPath As String, strDB As String
    
    
    'tmp = CurrentDb.Name    'or maybe this should be the name of your BE
    'strDBType = "FE"
    strDBpath = GetAccessBE_PathFilename("tblUser")
    'strPath = Left(strDBpath, InStrRev(strDBpath, "\"))
    strPath = Left(strDBpath, Len(strDBpath) - InStrRev(strDBpath, "\") + 1)
    strBackupPath = strPath & "Backup\"
    
    'Will now backup front and back end database
    If strDBType = "FE" Then
        strDBpath = CurrentDb.Name
    End If
    strDB = Right(strDBpath, Len(strDBpath) - InStrRev(strDBpath, "\"))
    
    With CreateObject("Scripting.FileSystemObject")
        'ext = "." & .GetExtensionName(tmp)
        tmp = strBackupPath & Format(Now(), "yyyymmdd_hhnnss") & "_" & strDB
        .CopyFile strDBpath, tmp
    End With
    MsgBox strDBType & " Database saved as " & tmp
    
    
End Sub

Function GetAccessBE_PathFilename(pTableName As String) As String
'strive4peace

   ' RETURN
   '  the file path and file name of the BE database
   '  "" if the table is not linked
   
   On Error GoTo Proc_Err
   
   Dim db As DAO.Database _
      , tdf As DAO.TableDef
   
   GetAccessBE_PathFilename = ""
   
   Set db = CurrentDb
   Set tdf = db.TableDefs(pTableName)
   
   If Len(tdf.Connect) = 0 Then
      GoTo Proc_Exit
   End If
   
   ' look at Connect string - Database Type is the first thing specified
   ' if the BE is Access
   If InStr(tdf.Connect, ";DATABASE=") <> 1 Then
      GoTo Proc_Exit
   End If
   
   GetAccessBE_PathFilename = Mid(tdf.Connect, 11)
    
Proc_Exit:
   On Error Resume Next
   Set tdf = Nothing
   Set db = Nothing
   Exit Function
  
Proc_Err:
   MsgBox Err.Description, , _
        "ERROR " & Err.Number _
        & "   GetAccessBE_PathFilename"

   Resume Proc_Exit
   Resume
             
End Function

Function CreateBackupFE()
' Have to do it this way as Switchboard does not allow parameters.
CreateBackup ("FE")
End Function
Function CreateBackupBE()
' Have to do it this way as Switchboard does not allow parameters.
CreateBackup ("BE")
End Function

MsgBox "Data backup at " & vbCrLf & MD_Date & vbCrLf & "successful!", _
        vbInformation, "Backup Successful"
 
Exit_BackupSource:
  Exit Function

MsgBox "Data backup at " & vbCrLf & MD_Date & vbCrLf & "successful!", _
        vbInformation, "Backup Successful"

Exit_Button_Backup:
    DoCmd.Quit

  Exit Sub

docmd.quit 'or:
application.closecurrentdatabase

Exit_Button_Backup:
    DoCmd.Quit