A
Afrosheen via AccessMonster.com
I'm using this routine to back up my database. The first part works as is.
What I want to do is to make the copy to A:\ drive.
1) strcopyfile = CurrentProject.Path & "\Copy of " & CurrentProject.Name
2) strcopyfile = CurrentProject. "A:\Copy of " & CurrentProject.Name
I keep on getting errors. Is there a way where I can save/backup a copy to A:\
drive?
Thanks for reading my post. It's been a great help.
This is the entire API that I'm using.
Option Compare Database
Option Explicit
'********** 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 Integer
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
10 On Local Error GoTo fMakeBackup_Err
20 If fDBExclusive = True Then Err.Raise cERR_DB_EXCLUSIVE
30 strMsg = "Are you sure that you want to make a copy of the database?
"
40 If MsgBox(strMsg, vbQuestion + vbYesNo, "Please confirm") = vbNo
Then _
Err.Raise cERR_USER_CANCEL
50 lngFlags = FOF_SIMPLEPROGRESS Or _
FOF_FILESONLY Or _
FOF_RENAMEONCOLLISION
60 strSaveFile = CurrentDb.Name
70 With tshFileOp
80 .wFunc = FO_COPY
90 .hWnd = hWndAccessApp
100 .pFrom = CurrentDb.Name & vbNullChar
110 .pTo = strSaveFile & vbNullChar
120 .fFlags = lngFlags
130 End With
140 lngRet = apiSHFileOperation(tshFileOp)
150 fMakeBackup = (lngRet = 0)
fMakeBackup_End:
160 Exit Function
fMakeBackup_Err:
170 fMakeBackup = False
180 Select Case Err.Number
Case cERR_USER_CANCEL:
'do nothing
190 Case cERR_DB_EXCLUSIVE:
200 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"
210 Case Else:
220 strMsg = "Error Information..." & vbCrLf & vbCrLf
230 strMsg = strMsg & "Function: fMakeBackup" & vbCrLf
240 strMsg = strMsg & "Description: " & Err.Description &
vbCrLf
250 strMsg = strMsg & "Error #: " & Format$(Err.Number) &
vbCrLf
260 MsgBox strMsg, vbInformation, "fMakeBackup"
270 End Select
280 Resume fMakeBackup_End
End Function
Private Function fCurrentDBDir() As String
'code courtesy of
'Terry Kreft
Dim strDBPath As String
Dim strDBFile As String
10 strDBPath = CurrentDb.Name
20 strDBFile = Dir(strDBPath)
30 fCurrentDBDir = Left(strDBPath, InStr(strDBPath, strDBFile) - 1)
End Function
Function fDBExclusive() As Integer
Dim db As Database
Dim hFile As Integer
10 hFile = FreeFile
20 Set db = CurrentDb
30 On Error Resume Next
40 Open db.Name For Binary Access Read Write Shared As hFile
50 Select Case Err
Case 0
60 fDBExclusive = False
70 Case 70
80 fDBExclusive = True
90 Case Else
100 fDBExclusive = Err
110 End Select
120 Close hFile
130 On Error GoTo 0
End Function
'************* Code End ***************
What I want to do is to make the copy to A:\ drive.
1) strcopyfile = CurrentProject.Path & "\Copy of " & CurrentProject.Name
2) strcopyfile = CurrentProject. "A:\Copy of " & CurrentProject.Name
I keep on getting errors. Is there a way where I can save/backup a copy to A:\
drive?
Thanks for reading my post. It's been a great help.
This is the entire API that I'm using.
Option Compare Database
Option Explicit
'********** 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 Integer
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
10 On Local Error GoTo fMakeBackup_Err
20 If fDBExclusive = True Then Err.Raise cERR_DB_EXCLUSIVE
30 strMsg = "Are you sure that you want to make a copy of the database?
"
40 If MsgBox(strMsg, vbQuestion + vbYesNo, "Please confirm") = vbNo
Then _
Err.Raise cERR_USER_CANCEL
50 lngFlags = FOF_SIMPLEPROGRESS Or _
FOF_FILESONLY Or _
FOF_RENAMEONCOLLISION
60 strSaveFile = CurrentDb.Name
70 With tshFileOp
80 .wFunc = FO_COPY
90 .hWnd = hWndAccessApp
100 .pFrom = CurrentDb.Name & vbNullChar
110 .pTo = strSaveFile & vbNullChar
120 .fFlags = lngFlags
130 End With
140 lngRet = apiSHFileOperation(tshFileOp)
150 fMakeBackup = (lngRet = 0)
fMakeBackup_End:
160 Exit Function
fMakeBackup_Err:
170 fMakeBackup = False
180 Select Case Err.Number
Case cERR_USER_CANCEL:
'do nothing
190 Case cERR_DB_EXCLUSIVE:
200 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"
210 Case Else:
220 strMsg = "Error Information..." & vbCrLf & vbCrLf
230 strMsg = strMsg & "Function: fMakeBackup" & vbCrLf
240 strMsg = strMsg & "Description: " & Err.Description &
vbCrLf
250 strMsg = strMsg & "Error #: " & Format$(Err.Number) &
vbCrLf
260 MsgBox strMsg, vbInformation, "fMakeBackup"
270 End Select
280 Resume fMakeBackup_End
End Function
Private Function fCurrentDBDir() As String
'code courtesy of
'Terry Kreft
Dim strDBPath As String
Dim strDBFile As String
10 strDBPath = CurrentDb.Name
20 strDBFile = Dir(strDBPath)
30 fCurrentDBDir = Left(strDBPath, InStr(strDBPath, strDBFile) - 1)
End Function
Function fDBExclusive() As Integer
Dim db As Database
Dim hFile As Integer
10 hFile = FreeFile
20 Set db = CurrentDb
30 On Error Resume Next
40 Open db.Name For Binary Access Read Write Shared As hFile
50 Select Case Err
Case 0
60 fDBExclusive = False
70 Case 70
80 fDBExclusive = True
90 Case Else
100 fDBExclusive = Err
110 End Select
120 Close hFile
130 On Error GoTo 0
End Function
'************* Code End ***************