Yep, my error. Told you it might have a few "buggies" in it. Try this:
Here is some code that I've pulled from one of my applications. It is
designed to run from a button on a form in the front end database, and makes
a copy of the backend database if all users other than the front end running
the code have disconnected from the backend. This would be useful for the
"manual" method.
You could run similar code via an AutoExec macro in a database file, where
the scheduler opens the file with the AutoExec macro in it. You'd need to
change UserCreateBackendBackup to a function; and then the AutoExec macro
would call the function via the RunCode action. But try this with the manual
setup first.
I took out a few things that are specific to that application, so it's
possible that you may get a compiler error the first time. Let me know if
you need assistance with this.
---------------------------
' ****************************************
' ** Subroutine UserCreateBackendBackup **
' ****************************************
Public Sub UserCreateBackendBackup()
' *** THIS SUBROUTINE IS USED TO ALLOW A USER TO CREATE A BACKUP COPY OF
' *** THE BACKEND DATABASE FILE IN ANOTHER LOCATION (e.g., ZIP DISC DRIVE,
' *** CD DRIVE, NETWORK LOCATION, etc.)
' Ken Snell 19 May 2005
Dim dbs_DB As DAO.Database
Dim datNowValue As Date
Dim xstrToLocation As String, strTempVar As String, strPathOfBE As String
Dim strPathFilenameOfBE As String, strFilenameOfBE As String
Dim tdf_DB As DAO.TableDef
On Error GoTo Err_CopyBackup
DoCmd.Hourglass True
Set dbs_DB = CurrentDb
' Get the path and filename of the "backend" file
For Each tdf_DB In dbs_DB.TableDefs
If Len(tdf_DB.Connect & "") > 0 Then
strPathFilenameOfBE = Replace(tdf_DB.Connect, ";DATABASE=", _
"", 1, -1, vbTextCompare)
Exit For
End If
Next tdf_DB
Set tdf_DB = Nothing
DoEvents
strFilenameOfBE = ExtractFileName(strPathFilenameOfBE)
strPathOfBE = ExtractPath(strPathFilenameOfBE)
' Check to see if an .ldb file exists for the current backend file. If yes,
tell user
' that someone is in the backend, and the copy cannot be created; then
reopen form
' "_frm_KeepRecordsetOpen" in *hidden* mode and exit the subroutine.
strTempVar = Dir(Left(strPathFilenameOfBE, _
Len(strPathFilenameOfBE) - 3) & strLockFileExtension)
If strTempVar <> "" Then
MsgBox "Someone else is still working in the database! The program " & _
"cannot make a copy of the ""backend"" file at this time." & _
vbCrLf & vbCrLf & "Try again later when no one other than you is
working " & _
"in the database.", vbCritical, "Cannot Copy Backend File!"
Else
' Provide the directory to the folder where the copy is to be put
xstrToLocation = "PathToWhereToPutTheBackendFile"
On Error Resume Next
If xstrToLocation <> "" Then
datNowValue = Now
' Copy the backend file to the selected location
FileCopy strPathFilenameOfBE, xstrToLocation & strFilenameOfBE
If Err.Number = 75 Then
MsgBox "You cannot create a file in the folder that you
selected:" & _
vbCrLf & Space(5) & """" & xstrToLocation & """" & vbCrLf &
vbCrLf & _
"The device may be a ""read-only"" device, or you may not
have " & _
"permission to write to the folder.", vbCritical, "Cannot
Create
File"
Err.Clear
Else
Open strPathOfBE & "Backend_Manually_Copied_On_" & _
Format(datNowValue, "ddmmmyyyy_hh.nn.ssAMPM") & ".txt" For
Output As #1
Print #1, "A copy of the backend database file ( """ &
strPathFilenameOfBE & _
""" ) was manually created by the front end's backup
feature:"
Print #1, " -- made on " & Format(datNowValue, "mmmm
dd, yyyy") & _
" at " & Format(datNowValue, "hh:nn:ss AMPM")
Print #1, " -- copied to """ & xstrToLocation &
strFilenameOfBE & """"
Print #1, " -- copied by """ & fOSUserName & """ from
computer """ & _
fOSMachineName & """"
Close #1
DoEvents
' Tell user that the copying was successful
MsgBox "The file has been created at" & vbCrLf & Space(5) &
xstrToLocation & _
strFilenameOfBE, vbInformation, "File Created"
End If
Else
MsgBox "No location was selected. No copy of the backend file will
be made.", _
vbExclamation, "No Location Selected"
End If
End If
Exit_CopyBackup:
On Error Resume Next
Set tdf_DB = Nothing
dbs_DB.Close
Set dbs_DB = Nothing
DoCmd.Hourglass False
Err.Clear
Exit Sub
Err_CopyBackup:
If Err.Number = 71 Then
MsgBox "The device that you selected ( """ & xstrToLocation & _
""" ) does not contain a disc or diskette. " & _
"The file cannot be copied to this device.", vbCritical, _
"No Disc or Diskette"
Else
MsgBox "An error has occurred while making a copy of the backend
database file:" & _
vbCrLf & " Error #" & Err.Number & ": " & Err.Description & vbCrLf
& vbCrLf & _
"Try again in a few minutes. If the problem persists, contact the
programmer for assistance.", _
vbCritical, "Error While Copying File"
End If
Resume Exit_CopyBackup
End Sub
' ********************************
' ** Function ExtractFileName **
' ********************************
Public Function ExtractFileName(ByVal strPathFile As String) As String
' *** THIS FUNCTION EXTRACTS THE "FILE NAME" PORTION OF A STRING THAT HOLDS
' *** THE FULL PATH AND FILENAME FOR A FILE. IT DOES THIS BY DROPPING
' *** THE PATH PORTION FROM THE STRING (ALL TEXT BEFORE THE LAST
' *** "\" CHARACTER IN THE STRING, AND THAT LAST "\" CHARACTER, TOO).
' *** IF THERE IS NO "\" CHARACTER IN THE TEXT STRING, THE FUNCTION RETURNS
' *** AN EMPTY STRING AS ITS VALUE. OTHERWISE, IT RETURNS THE "FILE NAME"
PORTION
' *** OF THE TEXT STRING.
' Ken Snell 19 May 2005
' strPathFile is string variable that contains the full path and filename
text string.
On Error Resume Next
If InStr(strPathFile, "\") = 0 Then
ExtractFileName = ""
Else
ExtractFileName = Mid(strPathFile, InStrRev(strPathFile, "\") + 1)
End If
Err.Clear
End Function
' ****************************
' ** Function ExtractPath **
' ****************************
Public Function ExtractPath(ByVal strPathFile As String) As String
' *** THIS FUNCTION EXTRACTS THE "PATH" PORTION OF A STRING THAT HOLDS
' *** THE FULL PATH AND FILENAME FOR A FILE. IT DOES THIS BY DROPPING
' *** THE FILENAME PORTION FROM THE STRING (ALL TEXT AFTER THE LAST
' *** "\" CHARACTER IN THE STRING).
' *** IF THERE IS NO "\" CHARACTER IN THE TEXT STRING, THE FUNCTION RETURNS
' *** AN EMPTY STRING AS ITS VALUE. OTHERWISE, IT RETURNS THE "PATH" PORTION
' *** (INCLUDING THE ENDING "\" CHARACTER) OF THE TEXT STRING.
' Ken Snell 19 May 2005
' strPathFile is string variable that contains the full path and filename
text string.
On Error Resume Next
If InStr(strPathFile, "\") = 0 Then
ExtractPath = ""
Else
ExtractPath = Left(strPathFile, InStrRev(strPathFile, "\"))
End If
Err.Clear
End Function
