Hi All,
I have managed to successfully use the following code to create a backup to A drive function but would like to now be able to restore a file from a floppy disc that has been zipped and put it back. ie do the reverse of what the follwing code does. Would someone be so kind as to tell me how to modify this or rewrite it.
Here it is:
Option Compare Database
Option Explicit
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
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 another 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 DB As DAO.Database
Dim sSourcePath As String
Dim sSourceFile As String
Dim sBackupPath As String
Dim sBackupFile As String
Dim strConnect As String
Dim strConnectFolder As String
strConnect = Mid(DBEngine(0)(0).TableDefs("Blocks1").Connect, Len(";DATABASE=") + 1)
Set DB = OpenDatabase(strConnect)
strConnectFolder = Left(DB.Name, Len(DB.Name) - Len(Dir(DB.Name)))
Set DB = CurrentDb
' This is the path and my file is called pv????
sSourcePath = strConnectFolder
sSourceFile = "VADataFile.mdb"
DoCmd.Hourglass True
'sBackupPath = "A:\"
If Dir("C:\Temp", vbDirectory) = "" Then MkDir ("C:\Temp")
sBackupPath = "C:\Temp\"
sBackupFile = "VADataFile_" & Format(Date, "ddmmyy") & ".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)
Sleep 10000 'ten second pause, 5000 = 5 seconds
DoCmd.Hourglass False
MsgBox "Your backup is nearly complete, please ensure you have a diskette with sufficient space ready in the A:\ drive.", vbInformation, "Vineyard ARKive Backup"
DoCmd.Hourglass True
Name sZipFile As "A:\" & sZipFileName
If Dir(sBackupPath & sBackupFile) <> "" Then Kill (sBackupPath & sBackupFile)
DoCmd.Hourglass False
Beep
MsgBox "Backup was successful and saved a copy to the A:\ drive." & Chr(13) & Chr(13) & "The backup file name is " & Chr(13) & Chr(13) & sZipFileName, vbInformation, "Backup Completed"
Exit_BackupAndZipitToDriveA:
DoCmd.Hourglass False
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.", vbCritical, "Vineyard ARKive Backup"
If Dir(sBackupPath & sBackupFile) <> "" Then Kill (sBackupPath & sBackupFile)
DoCmd.Hourglass False
Exit Function
ElseIf Err = 53 Then 'File not found
Beep
MsgBox "Source file can not be found!" & Chr(13) & Chr(13) & sSourceFile & Chr(13) & Chr(13) & "OR" & Chr(13) & Chr(13) & "You do not have WinZip installed, go to www.winzip.com to download your free evaluation version.", vbCritical, "Vineyard ARKive Backup"
DoCmd.Hourglass False
Exit Function
ElseIf Err = 75 Then 'Disk not ready
Beep
If Dir(sZipFile) <> "" Then Kill sZipFile
If Dir(sFileToZip) <> "" Then Kill sFileToZip
MsgBox "Please insert a diskette in drive A:\ and try again!", vbCritical, "Vineyard ARKive Backup"
DoCmd.Hourglass False
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 & sZipFile, vbCritical, "Vineyard ARKive Backup"
DoCmd.Hourglass False
Exit Function
ElseIf Err = 58 Then 'backup twice in one day
Beep
MsgBox "The diskette already contains a file with the same name, please insert another diskette or remove the file from the current diskette then try again!", vbCritical, "Vineyard ARKive Backup"
DoCmd.Hourglass False
Exit Function
Else
MsgBox Err.Number & " - " & Err.Description
Resume Exit_BackupAndZipitToDriveA
DoCmd.Hourglass False
End If
End Function
Thank you to all, lots and lots
Rachael
I have managed to successfully use the following code to create a backup to A drive function but would like to now be able to restore a file from a floppy disc that has been zipped and put it back. ie do the reverse of what the follwing code does. Would someone be so kind as to tell me how to modify this or rewrite it.
Here it is:
Option Compare Database
Option Explicit
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
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 another 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 DB As DAO.Database
Dim sSourcePath As String
Dim sSourceFile As String
Dim sBackupPath As String
Dim sBackupFile As String
Dim strConnect As String
Dim strConnectFolder As String
strConnect = Mid(DBEngine(0)(0).TableDefs("Blocks1").Connect, Len(";DATABASE=") + 1)
Set DB = OpenDatabase(strConnect)
strConnectFolder = Left(DB.Name, Len(DB.Name) - Len(Dir(DB.Name)))
Set DB = CurrentDb
' This is the path and my file is called pv????
sSourcePath = strConnectFolder
sSourceFile = "VADataFile.mdb"
DoCmd.Hourglass True
'sBackupPath = "A:\"
If Dir("C:\Temp", vbDirectory) = "" Then MkDir ("C:\Temp")
sBackupPath = "C:\Temp\"
sBackupFile = "VADataFile_" & Format(Date, "ddmmyy") & ".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)
Sleep 10000 'ten second pause, 5000 = 5 seconds
DoCmd.Hourglass False
MsgBox "Your backup is nearly complete, please ensure you have a diskette with sufficient space ready in the A:\ drive.", vbInformation, "Vineyard ARKive Backup"
DoCmd.Hourglass True
Name sZipFile As "A:\" & sZipFileName
If Dir(sBackupPath & sBackupFile) <> "" Then Kill (sBackupPath & sBackupFile)
DoCmd.Hourglass False
Beep
MsgBox "Backup was successful and saved a copy to the A:\ drive." & Chr(13) & Chr(13) & "The backup file name is " & Chr(13) & Chr(13) & sZipFileName, vbInformation, "Backup Completed"
Exit_BackupAndZipitToDriveA:
DoCmd.Hourglass False
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.", vbCritical, "Vineyard ARKive Backup"
If Dir(sBackupPath & sBackupFile) <> "" Then Kill (sBackupPath & sBackupFile)
DoCmd.Hourglass False
Exit Function
ElseIf Err = 53 Then 'File not found
Beep
MsgBox "Source file can not be found!" & Chr(13) & Chr(13) & sSourceFile & Chr(13) & Chr(13) & "OR" & Chr(13) & Chr(13) & "You do not have WinZip installed, go to www.winzip.com to download your free evaluation version.", vbCritical, "Vineyard ARKive Backup"
DoCmd.Hourglass False
Exit Function
ElseIf Err = 75 Then 'Disk not ready
Beep
If Dir(sZipFile) <> "" Then Kill sZipFile
If Dir(sFileToZip) <> "" Then Kill sFileToZip
MsgBox "Please insert a diskette in drive A:\ and try again!", vbCritical, "Vineyard ARKive Backup"
DoCmd.Hourglass False
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 & sZipFile, vbCritical, "Vineyard ARKive Backup"
DoCmd.Hourglass False
Exit Function
ElseIf Err = 58 Then 'backup twice in one day
Beep
MsgBox "The diskette already contains a file with the same name, please insert another diskette or remove the file from the current diskette then try again!", vbCritical, "Vineyard ARKive Backup"
DoCmd.Hourglass False
Exit Function
Else
MsgBox Err.Number & " - " & Err.Description
Resume Exit_BackupAndZipitToDriveA
DoCmd.Hourglass False
End If
End Function
Thank you to all, lots and lots
Rachael