Results 1 to 7 of 7

Backup subroutine with dir cmd to search dir is missing way to identify if a backup file is present

  1. #1
    Duncan Pucher is offline Advanced Beginner
    Windows 10 Access 2016
    Join Date
    Jun 2019
    Location
    Bellevue, WA
    Posts
    49

    Backup subroutine with dir cmd to search dir is missing way to identify if a backup file is present

    Forum Users,

    I would like to setup a backup process that is invoked in the autoexec file that runs the code for a backup but only create a backup once a day. Below is a backup subroutine "BackupBEDatabase()" that is working well. Also, I found code that identifies the filenames in the specified folder "Checkfolderforbackup()". With the code below and using lastmodifieddate I could check each file for a last date greater than today's date however the dir command randomly selects the files and multiple files could be other than today's date so I would end up with multiple backups each day. Could someone help with the VBA code to run the backup subroutine from autoexec but limit to once each day?



    files in Backup folder BE\*.*

    Carla_bev12_20190819161142.accdb
    Carla_bev12_20190815192551.accdb
    Carla_bev12_20190815190308.accdb


    Option Compare Database


    Private Sub Checkfolderforbackup()
    Dim strFileName As String
    'TODO: Specify path and file spec
    Dim strFolder As String: strFolder = "C:\Users\Duncan\Documents\Personal Documents\HIM Documents\Health Record Processes\Database\BE"


    Dim strFileSpec As String: strFileSpec = strFolder & "*.*"
    strFileName = Dir(strFileSpec)
    Do While Len(strFileName) > 0
    'TODO: replace Debug.Print by the process you want to do on the file
    Dim strFilePath As String: strFilePath = strFolder & strFileName
    Debug.Print strFileName
    strFileName = Dir
    Loop
    End Sub



    Option Compare Database
    Option Explicit


    Public Function BackupBEDatabase()


    On Error GoTo Err_Handler


    'Isladogs - minor changes made 23/07/2019
    'creates a copy of the backend database to the selected backups folder with date/time suffix


    Dim fso As Object
    Dim strFileName As String, strFilePath As String, strFileType As String, strBackupsFolder As String
    Dim strOldPath As String, strNewPath As String, strTempPath As String, strFileSize As String
    Dim newlength As Long
    Dim strPwd As String

    strPwd = "" 'Your BE password here

    strFileName = "Carla_bev12.accdb"
    'Isladogs - removed trailing backslashes
    strFilePath = "C:\Users\Duncan\Documents\Personal Documents\HIM Documents\Health Record Processes\Database\BE\Workingcopy"
    strBackupsFolder = "C:\Users\Duncan\Documents\Personal Documents\HIM Documents\Health Record Processes\Database"
    strFileType = Mid(strFileName, InStr(strFileName, ".")) 'e.g. .accdb

    strOldPath = strFilePath & "" & strFileName

    strNewPath = strBackupsFolder & "\BE" & _
    Left(strFileName, InStr(strFileName, ".") - 1) & "_" & Format(Now, "yyyymmddhhnnss") & strFileType

    strTempPath = strBackupsFolder & "" & _
    Left(strFileName, InStr(strFileName, ".") - 1) & "_TEMP" & strFileType



    'Debug.Print strOldPath
    'Debug.Print strTempPath
    'Debug.Print strNewPath

    'optional message - omit section if run automatically via scheduled task or similar
    If MsgBox("This procedure is used to make a backup copy of the Access back end database." & vbCrLf & _
    "The backup will be saved to the Backups folder with date/time suffix" & vbCrLf & _
    vbTab & "e.g. " & strNewPath & vbCrLf & vbCrLf & _
    "This can be used for recovery in case of problems " & vbCrLf & vbCrLf & _
    "Create a backup now?", _
    vbExclamation + vbYesNo, "Copy the Access BE database?") = vbNo Then
    Exit Function
    Else
    DoEvents

    StartBackup:
    Set fso = CreateObject("Scripting.FileSystemObject")


    'copy database to a temp file
    fso.CopyFile strOldPath, strTempPath
    Set fso = Nothing

    'compact the temp file
    'backup with password - if required
    'DBEngine.CompactDatabase strTempPath, strNewPath, ";PWD=" & strPwd & "", , ";PWD=" & strPwd & ""
    'no password
    DBEngine.CompactDatabase strTempPath, strNewPath

    'delete the tempfile
    Kill strTempPath

    DoEvents

    'OPTIONAL - 'get size of backup
    newlength = FileLen(strNewPath) 'in bytes

    'setup string to display file size
    If FileLen(strNewPath) < 1024 Then 'less than 1KB
    strFileSize = newlength & " bytes"
    ElseIf FileLen(strNewPath) < 1024 ^ 2 Then 'less than 1MB
    strFileSize = Round((newlength / 1024), 0) & " KB"
    ElseIf newlength < 1024 ^ 3 Then 'less than 1GB
    strFileSize = Round((newlength / 1024), 0) & " KB (" & Round((newlength / 1024 ^ 2), 1) & " MB)"
    Else 'more than 1GB
    strFileSize = Round((newlength / 1024), 0) & " KB (" & Round((newlength / 1024 ^ 3), 2) & " GB)"
    End If

    DoEvents

    End If

    'Optional success message - omit if run automatically
    MsgBox "The Access backend database has been successfully backed up." & vbCrLf & _
    "The backup file is called " & vbCrLf & vbTab & strNewPath & vbCrLf & vbCrLf & _
    "The file size is " & strFileSize, vbInformation, "Access BE Backup completed"

    Exit_Handler:
    Exit Function

    Err_Handler:
    Set fso = Nothing
    If Err <> 0 Then
    MsgBox "Error " & Err.Number & " in BackupBEDatabase procedure : " & vbCrLf & _
    Err.Description, vbCritical, "Error copying database"
    End If
    Resume Exit_Handler

    End Function
    Attached Files Attached Files

  2. #2
    rpeare is offline VIP
    Windows XP Access 2003
    Join Date
    Jul 2011
    Posts
    5,440
    I have not looked at your files yet but it seems to me you may have to write file name/relevant date (last modified) to a table within access, then process those in the order you want. I have run in to a similar problem and my solution was to create a file log table. I'll have a look at your files today if I can manage but it's at least one thing you can start working on.

  3. #3
    rpeare is offline VIP
    Windows XP Access 2003
    Join Date
    Jul 2011
    Posts
    5,440
    Plop this section of code into your existing backup code directly after the line of code defining strTempPath

    you can use the same mechanism to do an automatic backup every time you open the database or close the database and *not* prompt the user for a backup.


    Code:
    '******************************************************* ADDED THIS SECTION OF CODE ****************************
    Dim fsFolder
    Dim fsFile
    Dim sDate 
    Dim file
    Dim response
    
    
    sDate = Format(Date, "yyyymmdd")
    
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set fsFolder = fso.getfolder(strBackupsFolder & "\BE\")
    Set fsFile = fsFolder.Files
    
    
    response = vbYes
    
    
    For Each file In fsFile
        If InStr(file.Name, sDate) And InStr(file.Name, Left(strFileName, InStr(strFileName, ".") - 1)) Then
            response = MsgBox("There is an existing backup for the today's date (" & Date & ")" & vbCrLf & vbCrLf & "Are you sure you want to create another?", vbYesNo, "Confirm Duplicate Backup")
        End If
    Next file
    Set fsFile = Nothing
    Set fsFolder = Nothing
    
    
    If response = vbNo Then Exit Function
    '************************************************** END NEW SECTION OF CODE
    EDIT: you will want to regularly clean out the BE folder of old backup files either by moving them to a backup archive or deleting them to keep this check fairly speedy

  4. #4
    Duncan Pucher is offline Advanced Beginner
    Windows 10 Access 2016
    Join Date
    Jun 2019
    Location
    Bellevue, WA
    Posts
    49
    RPeare,

    I inserted the section of code and tested. I want it to run in an AutoExec file upon loading the program so the user doesn't know it is backing up (or not). I edited the section of code to remove the MsgBox. It tests all of the backup files and Exits the Function if a file date matches today's backup file date however when it finds no backup matching then it errors out and goes to the Error handler with the message: "Error Copying database Error 53 in Backupdatabase procedure: file not found". Could you check to see why this might occur?

    Thank you,




    Public Function BackupBEDatabase()


    On Error GoTo Err_Handler




    'Isladogs - minor changes made 23/07/2019
    'creates a copy of the backend database to the selected backups folder with date/time suffix




    Dim fso As Object
    Dim strFileName As String, strFilePath As String, strFileType As String, strBackupsFolder As String
    Dim strOldPath As String, strNewPath As String, strTempPath As String, strFileSize As String
    Dim newlength As Long
    Dim strPwd As String


    strPwd = "" 'Your BE password here


    strFileName = "Carla_bev12.accdb"
    'Isladogs - removed trailing backslashes
    strFilePath = "C:\Users\Duncan\Documents\Personal Documents\HIM Documents\Health Record Processes\Database\BE\Workingcopy"
    strBackupsFolder = "C:\Users\Duncan\Documents\Personal Documents\HIM Documents\Health Record Processes\Database"
    strFileType = Mid(strFileName, InStr(strFileName, ".")) 'e.g. .accdb


    strOldPath = strFilePath & "" & strFileName


    strNewPath = strBackupsFolder & "\BE" & _
    Left(strFileName, InStr(strFileName, ".") - 1) & "_" & Format(Now, "yyyymmddhhnnss") & strFileType


    strTempPath = strBackupsFolder & "" & _
    Left(strFileName, InStr(strFileName, ".") - 1) & "_TEMP" & strFileType


    Dim fsFolder
    Dim fsFile
    Dim sDate
    Dim file
    Dim response




    sDate = Format(Date, "yyyymmdd")




    Set fso = CreateObject("Scripting.FileSystemObject")
    Set fsFolder = fso.getfolder(strBackupsFolder & "\BE")
    Set fsFile = fsFolder.Files




    response = vbYes




    For Each file In fsFile
    If InStr(file.Name, sDate) And InStr(file.Name, Left(strFileName, InStr(strFileName, ".") - 1)) Then
    Exit Function
    'response = MsgBox("There is an existing backup for the today's date (" & Date & ")" & vbCrLf & vbCrLf & "Are you sure you want to create another?", vbYesNo, "Confirm Duplicate Backup")
    End If
    Next file
    Set fsFile = Nothing
    Set fsFolder = Nothing


    'I removed vbYesNo MsgBox
    'If response = vbNo Then Exit Function




    'Debug.Print strOldPath
    'Debug.Print strTempPath
    'Debug.Print strNewPath


    'optional message - omit section if run automatically via scheduled task or similar
    If MsgBox("This procedure is used to make a backup copy of the Access back end database." & vbCrLf & _
    "The backup will be saved to the Backups folder with date/time suffix" & vbCrLf & _
    vbTab & "e.g. " & strNewPath & vbCrLf & vbCrLf & _
    "This can be used for recovery in case of problems " & vbCrLf & vbCrLf & _
    "Create a backup now?", _
    vbExclamation + vbYesNo, "Copy the Access BE database?") = vbNo Then
    Exit Function
    Else
    DoEvents


    StartBackup:
    Set fso = CreateObject("Scripting.FileSystemObject")




    'copy database to a temp file
    fso.CopyFile strOldPath, strTempPath
    Set fso = Nothing


    'compact the temp file
    'backup with password - if required
    'DBEngine.CompactDatabase strTempPath, strNewPath, ";PWD=" & strPwd & "", , ";PWD=" & strPwd & ""
    'no password
    DBEngine.CompactDatabase strTempPath, strNewPath


    'delete the tempfile
    Kill strTempPath


    DoEvents


    'OPTIONAL - 'get size of backup
    newlength = FileLen(strNewPath) 'in bytes


    'setup string to display file size
    If FileLen(strNewPath) < 1024 Then 'less than 1KB
    strFileSize = newlength & " bytes"
    ElseIf FileLen(strNewPath) < 1024 ^ 2 Then 'less than 1MB
    strFileSize = Round((newlength / 1024), 0) & " KB"
    ElseIf newlength < 1024 ^ 3 Then 'less than 1GB
    strFileSize = Round((newlength / 1024), 0) & " KB (" & Round((newlength / 1024 ^ 2), 1) & " MB)"
    Else 'more than 1GB
    strFileSize = Round((newlength / 1024), 0) & " KB (" & Round((newlength / 1024 ^ 3), 2) & " GB)"
    End If


    DoEvents


    End If


    'Optional success message - omit if run automatically
    MsgBox "The Access backend database has been successfully backed up." & vbCrLf & _
    "The backup file is called " & vbCrLf & vbTab & strNewPath & vbCrLf & vbCrLf & _
    "The file size is " & strFileSize, vbInformation, "Access BE Backup completed"


    Exit_Handler:
    Exit Function


    Err_Handler:
    Set fso = Nothing
    If Err <> 0 Then
    MsgBox "Error " & Err.Number & " in BackupBEDatabase procedure : " & vbCrLf & _
    Err.Description, vbCritical, "Error copying database"
    End If
    Resume Exit_Handler


    End Function

  5. #5
    rpeare is offline VIP
    Windows XP Access 2003
    Join Date
    Jul 2011
    Posts
    5,440
    encapsulate your code on this forum in tags to make it readable.

    This is how I wrote the function:

    Code:
    Public Function BackupBEDatabase()
    
    
    On Error GoTo ERR_Handler
    
    
    'Isladogs - minor changes made 23/07/2019
    'creates a copy of the backend database to the selected backups folder with date/time suffix
    
    
    Dim fso As Object
    Dim strFileName As String, strFilePath As String, strFileType As String, strBackupsFolder As String
    Dim strOldPath As String, strNewPath As String, strTempPath As String, strFileSize As String
    Dim newlength As Long
    Dim strPwd As String
    Dim fsFolder
    Dim fsFile
    Dim sDate As String
    Dim file
    Dim response
    
    
    strPwd = "" 'Your BE password here
    strFileName = "Carla_bev12.accdb"
    strFilePath = CurrentProject.Path
    strBackupsFolder = Replace(CurrentProject.Path & "\", "\\", "\") & "Backup"
    strFileType = Mid(strFileName, InStr(strFileName, ".")) 'e.g. .accdb
    strOldPath = strFilePath & "\" & strFileName
    strNewPath = strBackupsFolder & "\BE\" & Left(strFileName, InStr(strFileName, ".") - 1) & "_" & Format(Now, "yyyymmddhhnnss") & strFileType
    strTempPath = strBackupsFolder & "\TEMP\" & Left(strFileName, InStr(strFileName, ".") - 1) & "_TEMP" & strFileType
    
    
    sDate = Format(Date, "yyyymmdd")
    
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set fsFolder = fso.getfolder(strBackupsFolder & "\BE\")
    Set fsFile = fsFolder.Files
    
    
    For Each file In fsFile
        If InStr(file.Name, sDate) And InStr(file.Name, Left(strFileName, InStr(strFileName, ".") - 1)) Then
            Exit Function
        End If
    Next file
    
    
    Set fsFile = Nothing
    Set fsFolder = Nothing
    
    
    StartBackup:
        fso.CopyFile strOldPath, strTempPath
        Set fso = Nothing
        DBEngine.CompactDatabase strTempPath, strNewPath
        Kill strTempPath
        
    Exit Function
                    
    ERR_Handler:
        Exit Function
    
    
    End Function
    in the ON OPEN event of frmResidents call the function BackupBEDatabase

    I did not peel out the extraneous variables from the code, just stripped it down to the bare minimum and took out all the message boxes etc.

  6. #6
    Duncan Pucher is offline Advanced Beginner
    Windows 10 Access 2016
    Join Date
    Jun 2019
    Location
    Bellevue, WA
    Posts
    49
    Rpeare,

    I tested the code. Thanks for the tip to use "for each file in". I appreciate it.

  7. #7
    rpeare is offline VIP
    Windows XP Access 2003
    Join Date
    Jul 2011
    Posts
    5,440
    mark it solved!

Please reply to this thread with any new information or opinions.

Similar Threads

  1. Replies: 13
    Last Post: 04-09-2019, 04:46 AM
  2. VBA to create dated backup file
    By phbryan in forum Programming
    Replies: 2
    Last Post: 03-30-2015, 04:51 PM
  3. Search employees backup database
    By mademen in forum Access
    Replies: 4
    Last Post: 12-19-2011, 03:30 PM
  4. SQL Server Differential backup in a separate file
    By buienxg in forum SQL Server
    Replies: 2
    Last Post: 12-17-2011, 04:41 PM
  5. Automatically createing Backup.mdb file
    By nareshk in forum Access
    Replies: 3
    Last Post: 11-16-2009, 12:47 PM

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  
Tech Forums: Microsoft Office Forums