automatic backup

[Kevin Wilcox]

I’m backing up my BE from within Access; although the filesize is relatively modest (15Mb) for this day and age it can take 3 or 4 minutes for the backup to be completed. There’s nothing I can do about that, it’s a network issue beyond my control. My problem is that Access is semi-suspended whilst the backup takes place; I say semi-suspended because if the user goes into another windows app e.g. explorer, word etc, and then back into access, the screen will go blank and it will appear as though access has hung. It hasn’t of course, it’s just waiting for the backup to be compoleted.

Hiding the windows file copy dialog has no effect on the problem, just means there’s nothing to view. Ditto putting up a little popup to say ‘backing up, please wait’ etc.

Ideally I’d like to trigger the backup and immediately return control to the user with the file copy taking place entirely outside of Access. I’ve tried triggering a batch file instead of an API call, but this too makes no difference, the problem remains. Alternatively I’d settle for ‘locking’ the user into access until the code has finished. Does anyone have a solution for either of these, or a better suggestion. Unfortunately I can’t take the easy and obvious route (network backup), that would require a degree of coordination well beyond this organisation!

[MMcCarthy]

What code exactly are you using for the backup. Can you post the code?

[Kevin Wilcox]

What code exactly are you using for the backup. Can you post the code?

Sorry for the timelag, holidays etc; as you can see this is quite a long chunk of code!
Thanks
Kevin

Option Compare Database
 
Function DailyBackup()
On Error GoTo Proc_Err
 
Dim NumberLoggedIn
Dim MyDay
Dim MyMonth
Dim MyYear
Dim MyExpiredBackup
Dim fs
Dim strSaveFile As String
 
Application.Echo False
 
If EnableBackups = -1 Then
    Set fs = CreateObject("Scripting.FileSystemObject")
    strSaveFile = BackUpDirectory & Day(Date) & "-" & Month(Date) & "-" & Year(Date) & " Backup " & BE_FileName
    If fs.FileExists(strSaveFile) = True Then
        Set fs = Nothing
        GoTo Proc_Exit
    End If
 
    MyDay = Day(Date - 7)
    MyMonth = Month(Date - 7)
    MyYear = Year(Date - 7)
    MyExpiredBackup = BackUpDirectory & MyYear & "-" & MyMonth & "-" & MyDay & " Backup " & BE_FileName
 
    NumberLoggedIn = DLookup("[MyCount]", "qryLoggedInCount", "[LoggedIn] = -1 ")
 
    If NumberLoggedIn = 1 Then
        fMakeBackup
        If fs.FileExists(MyExpiredBackup) = True Then
            Kill MyExpiredBackup
            Set fs = Nothing
        End If
    End If
End If
 
Proc_Exit:
    Application.Echo True
    Exit Function
 
Proc_Err:
    MsgBox "Oops, that must be error number " & Err.Number & ": " & Err.Description, vbInformation + vbOKOnly + vbDefaultButton1, "Case Management Database"
    Resume Proc_Exit
 
End Function
 
 
'********** Code Start *************
' This code was originally written by Dev Ashish.
' It is not to be altered or distributed,
' except as part of an application.
' You are free to use it in any application,
' provided the copyright notice is left unchanged.
'
' Code Courtesy of
' Dev Ashish
'
Private Type SHFILEOPSTRUCT
    hwnd As Long
    wFunc As Long
    pFrom As String
    pTo As String
    fFlags As Long
    fAnyOperationsAborted As Boolean
    hNameMappings As Long
    lpszProgressTitle As String
End Type
 
Private Const FO_MOVE As Long = &H1
Private Const FO_COPY As Long = &H2
Private Const FO_DELETE As Long = &H3
Private Const FO_RENAME As Long = &H4
 
Private Const FOF_MULTIDESTFILES As Long = &H1
Private Const FOF_CONFIRMMOUSE As Long = &H2
Private Const FOF_SILENT As Long = &H4
Private Const FOF_RENAMEONCOLLISION As Long = &H8
Private Const FOF_NOCONFIRMATION As Long = &H10
Private Const FOF_WANTMAPPINGHANDLE As Long = &H20
Private Const FOF_CREATEPROGRESSDLG As Long = &H0
Private Const FOF_ALLOWUNDO As Long = &H40
Private Const FOF_FILESONLY As Long = &H80
Private Const FOF_SIMPLEPROGRESS As Long = &H100
Private Const FOF_NOCONFIRMMKDIR As Long = &H200
 
Private Declare Function apiSHFileOperation Lib "Shell32.dll" _
            Alias "SHFileOperationA" _
            (lpFileOp As SHFILEOPSTRUCT) _
            As Long
 
Function fMakeBackup() As Boolean
Dim strMsg As String
Dim tshFileOp As SHFILEOPSTRUCT
Dim lngRet As Long
Dim strSaveFile As String
Dim lngFlags As Long
 
Const cERR_USER_CANCEL = vbObjectError + 1
Const cERR_DB_EXCLUSIVE = vbObjectError + 2
    On Local Error GoTo fMakeBackup_Err
 
    If fDBExclusive = True Then Err.Raise cERR_DB_EXCLUSIVE
 
    'strMsg = "Are you sure that you want to make a copy of the database?"
    'If MsgBox(strMsg, vbQuestion + vbYesNo, "Please confirm") = vbNo Then _
            Err.Raise cERR_USER_CANCEL
 
    lngFlags = FOF_SIMPLEPROGRESS Or _
                            FOF_FILESONLY Or _
                            FOF_RENAMEONCOLLISION
    'previously used fCurrentDBDir etc
    'strSaveFile = fCurrentDBDir & Day(Date) & "-" & Month(Date) & "-" & Year(Date) & " Backup " & fCurrentDBFile
    strSaveFile = BackUpDirectory & Day(Date) & "-" & Month(Date) & "-" & Year(Date) & " Backup " & BE_FileName
 
    With tshFileOp
        .wFunc = FO_COPY
        .hwnd = hWndAccessApp
        '.pFrom = CurrentDb.Name & vbNullChar
        .pFrom = BackUpDirectory & BE_FileName ' & vbNullChar
        .pTo = strSaveFile & vbNullChar
        .fFlags = lngFlags
    End With
    lngRet = apiSHFileOperation(tshFileOp)
    fMakeBackup = (lngRet = 0)
 
fMakeBackup_End:
    Exit Function
fMakeBackup_Err:
    fMakeBackup = False
    Select Case Err.Number
        Case cERR_USER_CANCEL:
            'do nothing
        Case cERR_DB_EXCLUSIVE:
            MsgBox "The current database " & vbCrLf & CurrentDb.Name & vbCrLf & _
                    vbCrLf & "is opened exclusively.  Please reopen in shared mode" & _
                    " and try again.", vbCritical + vbOKOnly, "Database copy failed"
        Case Else:
            strMsg = "Error Information..." & vbCrLf & vbCrLf
            strMsg = strMsg & "Function: fMakeBackup" & vbCrLf
            strMsg = strMsg & "Description: " & Err.Description & vbCrLf
            strMsg = strMsg & "Error #: " & Format$(Err.Number) & vbCrLf
            MsgBox strMsg, vbInformation, "fMakeBackup"
    End Select
    Resume fMakeBackup_End
End Function
 
Private Function fCurrentDBDir() As String
'code courtesy of
'Terry Kreft
Dim strDBPath As String
Dim strDBFile As String
    strDBPath = CurrentDb.Name
    strDBFile = Dir(strDBPath)
    fCurrentDBDir = Left(strDBPath, InStr(strDBPath, strDBFile) - 1)
End Function
 
Private Function fCurrentDBFile() As String
'code courtesy of
'Terry Kreft
Dim strDBPath As String
Dim strDBFile As String
    strDBPath = CurrentDb.Name
    strDBFile = Dir(strDBPath)
    fCurrentDBFile = strDBFile
End Function
 
Function fDBExclusive() As Long
Dim DB As Database
Dim hFile As Long
    hFile = FreeFile
    Set DB = CurrentDb
    On Error Resume Next
    Open DB.Name For Binary Access Read Write Shared As hFile
    Select Case Err
        Case 0
            fDBExclusive = False
        Case 70
            fDBExclusive = True
        Case Else
            fDBExclusive = Err
    End Select
    Close hFile
    On Error GoTo 0
End Function
'************* Code End ***************