Function IsBackendInUse() As Boolean
Dim strBackendPath As String
Dim intFileNum As Integer
strBackendPath = BackEndPath()
On Error Resume Next
intFileNum = FreeFile
Open strBackendPath For Binary Access Read Lock Read Write As #intFileNum
Close #intFileNum
If Err.Number <> 0 Then
IsBackendInUse = True ' File is locked
Else
IsBackendInUse = False ' File is available
End If
On Error GoTo 0
End Function
Public Sub BackupBackendDatabase()
Dim strSourcePath As String
Dim strBackupPath As String
Dim strBackupFileName As String
' change this to the correct path to your backup folder
strBackupPath = Environ("userprofile") & "\documents\backup\"
' Path to your backend database
strSourcePath = BackEndPath()
' Backup location with timestamp
'strBackupFileName = GetBaseName(strSourcePath) & "_" & Format(Now(), "yyyy-mm-dd_hhnnss") & "." & GetExtension(strSourcePath)
Dim strBaseName As String
strBaseName = GetBaseName(strSourcePath)
If Right(strBaseName, 3) = "_be" Then
strBackupFileName = Left$(strBaseName, Len(strBaseName) - 3) & Format$(Date, "mmm") & "_be"
Else
strBackupFileName = GetBaseName(strSourcePath) & Format$(Date, "ddd")
End If
strBackupFileName = strBackupFileName & "." & GetExtension(strSourcePath)
' Create backup folder if it doesn't exist
If Dir(strBackupPath, vbDirectory) = "" Then
MkDir strBackupPath
End If
strBackupPath = strBackupPath & strBackupFileName
' Copy the backend database
On Error Resume Next
FileCopy strSourcePath, strBackupPath
If Err.Number = 0 Then
MsgBox "Backup created successfully: " & strBackupFileName, vbInformation
Else
MsgBox "Backup failed: " & Err.Description, vbExclamation
End If
On Error GoTo 0
End Sub
Public Function BackEndPath$()
Const conString = ";DATABASE="
Dim td As DAO.TableDef
Dim db As DAO.Database: Set db = CurrentDb
Dim conn$
For Each td In db.TableDefs
conn = td.Connect
If Len(conn) <> 0 Then
If InStr(1, conn, conString) = 1 Then
BackEndPath = Mid$(conn, Len(conString) + 1)
Exit For
End If
End If
Next
Set td = Nothing: Set db = Nothing
End Function
' helper
Function GetFileName(strPath As String) As String
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
GetFileName = fso.GetFileName(strPath)
Set fso = Nothing
End Function
Function GetExtension(strPath As String) As String
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
GetExtension = fso.GetExtensionName(strPath)
Set fso = Nothing
End Function
Function GetBaseName(strPath As String) As String
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
GetBaseName = fso.GetBaseName(strPath) ' Filename without extension
Set fso = Nothing
End Function
