Public Function BackupAndZipitToDriveA()
On Error GoTo Err_BackupAndZipitToDriveA
'This function will allow you to copy a db that is open,
'rename the copied db and zip it up to anther folder.
'You must set a reference to the 'Microsoft Scripting Runtime' for the CopyFile piece to work!
'Thanks to Ricky Hicks for the .CopyFile code
Dim fso As FileSystemObject
Dim sSourcePath As String
Dim sSourceFile As String
Dim sBackupPath As String
Dim sBackupFile As String
sSourcePath = "C:\Database\"
sSourceFile = "MyDB.mdb"
If Dir("C:\Temp", vbDirectory) = "" Then MkDir ("C:\Temp")
sBackupPath = "C:\Temp\"
sBackupFile = "BackupDB_" & Format(Date, "mmddyyyy") & "_" & Format(Time, "hhmmss") & ".mdb"
Set fso = New FileSystemObject
fso.CopyFile sSourcePath & sSourceFile, sBackupPath & sBackupFile, True
Set fso = Nothing
Dim sWinZip As String
Dim sZipFile As String
Dim sZipFileName As String
Dim sFileToZip As String
sWinZip = "C:\Program Files\WinZip\WinZip32.exe" 'Location of the WinZip program
sZipFileName = Left(sBackupFile, InStr(1, sBackupFile, ".", vbTextCompare) - 1) & ".zip"
sZipFile = sBackupPath & sZipFileName
sFileToZip = sBackupPath & sBackupFile
Call Shell(sWinZip & " -a " & sZipFile & " " & sFileToZip, vbHide)
Name sZipFile As "A:\" & sZipFileName
Beep
MsgBox "Backup was successful and saved @ " & Chr(13) & Chr(13) & "A:\" & Chr(13) & Chr(13) & "The backup file name is " & Chr(13) & Chr(13) & sZipFileName, vbInformation, "Backup Completed"
If Dir(sBackupPath & sBackupFile) <> "" Then Kill (sBackupPath & sBackupFile)
Exit_BackupAndZipitToDriveA:
Exit Function
Err_BackupAndZipitToDriveA:
If Err = 5 Then 'Invalid procedure call or argument
Beep
MsgBox "Disk is full! Can not move the zip file to the A:\ drive. Please move the " & sZipFile & " file to a safe location." & vbNewLine & vbNewLine & sSourceDB, vbCritical
If Dir(sBackupPath & sBackupFile) <> "" Then Kill (sBackupPath & sBackupFile)
Exit Function
ElseIf Err = 53 Then 'File not found
Beep
MsgBox "Source file can not be found!" & vbNewLine & vbNewLine & sSourceDB, vbCritical
Exit Function
ElseIf Err = -2147024784 Then 'Method 'CopyFile' of object 'IFileSystem3' faild
Beep
MsgBox "File is to large to be zipped onto the A:\ drive!" & vbNewLine & vbNewLine & sSourceDB, vbCritical
Exit Function
Else
MsgBox Err.Number & " - " & Err.Description
Resume Exit_BackupAndZipitToDriveA
End If
End Function