Option Compare Database
Option Explicit
Public strWinZipPath As String
Function InitializeBackUp()
Dim strErrMsg As String
Dim strErrTitle As String
Dim strMsg As String
strErrMsg = " BackUp Action cancelled. Database not backed up. "
strErrTitle = " BackUp Cancelled"
strMsg = "WinZip has been found. The Database will be compressed and saved as a WinZip file. "
DoCmd.OpenForm "Filenames", , , , , acHidden
If IsNull(Forms!FileNames.BackUpFrom) Or Forms!FileNames.BackUpFrom = "" Then
MsgBox " No Data File selected. Database not backed up. ", vbCritical, " Dean's Software"
Exit Function
End If
If IsNull(Forms!FileNames.BackUpTo) Or Forms!FileNames.BackUpTo = "" Then
MsgBox " No Destination Directory selected. Database not backed up. ", vbCritical, " Dean'sr Software"
Exit Function
End If
'Find Winzip
If Dir("C:\Program Files\WinZip\WinZip32.exe", vbDirectory) <> "" Then 'WinXP
If MsgBox(strMsg, vbInformation + vbOKCancel, " Commencing BackUp") = vbOK Then
strWinZipPath = "C:\Program Files\WinZip\WinZip32.exe"
Call ZipandBackUpDb
Else
MsgBox strErrMsg, vbCritical, strErrTitle
End If
Else
If MsgBox("WinZip cannot be Located. The Database will be saved as a copy. ", vbInformation + vbOKCancel, " Commencing BackUp") = vbOK Then
Call BackUpDb
Else
MsgBox strErrMsg, vbCritical, strErrTitle
End If
End If
DoCmd.Close acForm, "FileNames"
End Function
Function ZipandBackUpDb() 'WinZip Found
On Error GoTo Err_BackUpDb
Dim fso, fl 'Add line Alastair 69 (08/02/2006)
Dim sSourcePath As String
Dim sSourceFile As String
Dim sBackupPath As String
Dim sBackupFile As String
Dim strFileName As String
Dim sBackupFolder As String
Dim sFinalPath As String
Dim sFilePart As String
Dim strError As String
strFileName = Forms!FileNames.BackUpFrom
sSourcePath = strFileName
If Not Dir("C:\Temp", vbDirectory) <> "" Then MkDir "C:\Temp"
sBackupPath = "C:\Temp\"
'Get the final part of the file
sFilePart = ParseFileName(sSourcePath, 1)
sFilePart = strReplace(sFilePart, " ", "_")
sBackupFile = sFilePart
sBackupFolder = Forms!FileNames.BackUpTo
sFinalPath = sBackupFolder & "\"
Screen.MousePointer = 11
Set fso = CreateObject("Scripting.FileSystemObject") 'Add line Alastair 69 (11/02/2006)
fso.CopyFile sSourcePath, sBackupPath & sBackupFile, True
Set fso = Nothing
Dim sWinZip As String
Dim sZipFile As String
Dim sZipFileName As String
Dim sFileToZip As String
sWinZip = strWinZipPath 'Location of the WinZip program
sZipFileName = Left(sBackupFile, InStr(1, sBackupFile, ".", vbTextCompare) - 1) & "_" & Format(Date, "dd-mm-yyyy") & "-" & Format(Time, "hh-mmAMPM") & ".zip"
sZipFile = sBackupPath & sZipFileName
sFileToZip = sBackupPath & sBackupFile
Call Shell(sWinZip & " -a " & sZipFile & " " & sFileToZip, vbHide)
Call RunProgMeter
'Set fso = New filesystemobject
Set fso = CreateObject("Scripting.FileSystemObject") 'Add line Alastair 69 (08/02/2006)
fso.CopyFile sBackupPath & sZipFileName, sFinalPath & sZipFileName, True
Set fso = Nothing
Screen.MousePointer = 0
MsgBox "Backup was successful. " & "The backup file is named: " & Chr(13) & " " & sFinalPath & sZipFileName, vbInformation, "Backup Completed"
If Dir(sBackupPath & sBackupFile) <> "" Then Kill (sBackupPath & sBackupFile)
If Dir(sBackupPath & sZipFileName) <> "" Then Kill (sBackupPath & sZipFileName)
Exit_BackUpDb:
Exit Function
Err_BackUpDb:
Select Case Err.Number
Case 5
strError = "Disk is full! Can not move the zip file to the Drive. Please move the " & sZipFile & " file to a safe location."
If Dir(sBackupPath & sBackupFile) <> "" Then Kill (sBackupPath & sBackupFile)
If Dir(sBackupPath & sZipFileName) <> "" Then Kill (sBackupPath & sZipFileName)
Case 53
strError = "Disk is full! Can not move the zip file to the Drive. Please move the " & sZipFile & " file to a safe location."
Case 71
If Dir(sZipFile) <> "" Then Kill sZipFile
If Dir(sFileToZip) <> "" Then Kill sFileToZip
strError = "There is no diskette in the Drive. "
Case -2147024784
strError = "File is to large to be zipped to the Drive!" & vbNewLine & sZipFile
Case Else
strError = Err.Description
End Select
MsgBox Err.Number & " - " & strError, vbCritical, " BackUp Error"
Screen.MousePointer = 0
Resume Exit_BackUpDb
End Function
Function BackUpDb() 'No WinZip
On Error GoTo Err_BackUpDb
Dim fso, fl 'Add line Alastair 69 (08/02/2006)
Dim sSourcePath As String
Dim sBackupPath As String
Dim sBackupFile As String
Dim strFileName As String
Dim sBackupFolder As String
Dim sFilePart As String
Dim sFileExtension As String
strFileName = Forms!FileNames.BackUpFrom
sSourcePath = strFileName
'Establish the file name to allow the same name to be used
sFilePart = ParseFileName(sSourcePath, 2)
'Establish the extension and make the copy the same. (*.mdb stays *.mdb,*.mde stays *.mde etc)
sFileExtension = ParseFileName(sSourcePath, 3)
sBackupFolder = Forms!FileNames.BackUpTo
sBackupPath = sBackupFolder & "\"
sBackupFile = sFilePart & "_" & Format(Date, "dd-mm-yyyy") & "-" & Format(Time, "hh-mmAMPM") & sFileExtension
Screen.MousePointer = 11
Call RunProgMeter
Screen.MousePointer = 0
Set fso = CreateObject("Scripting.FileSystemObject") 'Add line Alastair 69 (08/02/2006)
fso.CopyFile sSourcePath, sBackupPath & sBackupFile, True
Set fso = Nothing
MsgBox "BackUp Complete. Backup file is located at " & sBackupPath & sBackupFile, vbInformation, " DCA Expro BackUp"
Exit_BackUpDb:
Exit Function
Err_BackUpDb:
MsgBox Err.Number & " - " & Err.Description, vbCritical, " BackUp Failure"
Resume Exit_BackUpDb
End Function
Function FindBackUpFile()
Dim strPath As String
Dim InitDir As String
CDSearchString = MakeFilterString("Database Files (*.mdb;*.adp;*.mdw;*.mda;*.mde)", "*.mdb;*.adp;*.mdw;*.mda;*.mde", "All Files (*.*)", "*.*")
CDCaption = "Select Database File to Back Up..."
strPath = LaunchCD
If Not strPath = "None Selected" Then
FindBackUpFile = strPath
Else
FindBackUpFile = "None Selected"
End If
End Function
Function FindBackUpFolder()
Dim strFolderName As String
strFolderName = BrowseFolder("Select Folder to BackUp to")
If IsNull(strFolderName) Or strFolderName = "" Then
FindBackUpFolder = "None Selected"
Else
FindBackUpFolder = strFolderName
End If
End Function
Private Function ParseFileName(sfPath As String, Optional iRet As Long)
On Error GoTo ParseFileName_Err
Dim sFullName As String
Dim sFilePathOnly As String
Dim sDrive As String
Dim sPath As String
Dim sLocation As String
Dim sFilename As String
Dim sShortName As String
Dim sExt As String
sFullName = sfPath
' Find the final "\" in the path.
sPath = sFullName
Do While Right$(sPath, 1) <> "\"
sPath = Left$(sPath, Len(sPath) - 1)
Loop
' Find the Drive.
sDrive = Left$(sFullName, InStr(sFullName, ":") + 1)
'tbDrive = sDrive
' Find the Location.
sLocation = Mid$(sPath, Len(sDrive) - 2)
'tbLocation = sLocation
' Find the Path.
sPath = Mid$(sPath, Len(sDrive) + 1)
'tbPath = sPath
' Find the file name.
sFilename = Mid$(sFullName, Len(sPath) + 4)
Select Case iRet
Case 1
sFilename = Mid$(sFullName, Len(sPath) + 4)
ParseFileName = sFilename
Case 2
sShortName = Left$(sFilename, Len(sFilename) - 4)
ParseFileName = sShortName
Case 3
sExt = Right$(sFilename, 4)
ParseFileName = sExt
End Select
ParseFileName_Exit:
Exit Function
ParseFileName_Err:
MsgBox Err.Number & " - " & Err.Description
Resume ParseFileName_Exit
End Function
Function strReplace(sMainString As String, _
sSubString As String, strReplaceString As String) As String
'* Recursive function to replace all occurences of sSubString
'* with strReplaceString in sMainString
Dim I As Integer
Dim ipos As Integer
Dim S As String
Dim s1 As String, s2 As String
S = sMainString
ipos = InStr(1, sMainString, sSubString)
If ipos = 0 Then
GoTo Exit_strReplace
End If
s1 = Mid(sMainString, 1, ipos - 1)
s2 = Mid(sMainString, ipos + Len(sSubString), Len(sMainString))
S = s1 & strReplaceString & _
strReplace(s2, sSubString, strReplaceString)
Exit_strReplace:
strReplace = S
End Function
Function RunProgMeter()
Dim mwth As Long
Dim mstep As Long
mstep = 0
mwth = Forms!backup!Box7.Width
Forms!backup!Box7.Visible = True
Forms!backup!Box8.Width = 0
Forms!backup!Box8.Visible = True
Do Until mstep >= mwth
Forms!backup!Box8.Width = mstep
mstep = mstep + 2
DoEvents
Loop
Forms!backup!Box8.Visible = False
Forms!backup!Box7.Visible = False
End Function
