Follow along with the video below to see how to install our site as a web app on your home screen.
Note: This feature may not be available in some browsers.
Option Compare Database
Public Function Checkupdate()
On Error GoTo Err_Checkupdate
Dim strSource As String, strError As String
Dim strDate As String, strDateX As String
Dim fso As FileSystemObject
Dim CurrentVersion As String, UserVersion As String
Dim Thisdb As DAO.Database, ThisRs As DAO.Recordset
Dim db As DAO.Database, Rs As DAO.Recordset
Dim Release As Byte, CRelease As Byte
Dim MasterDB As String
'Path to master front end file in shared folder
MasterDB = "\\nawespscfs02vb\CommandI\CINCPACFLT\SDNI\CNI-CNRSW\CNRSW_CBHousing\Database\Maintenance Management Master.mdb"
Set db = OpenDatabase(MasterDB)
Set Thisdb = CurrentDb
Set ThisRs = Thisdb.OpenRecordset("tblUserVersion")
Set Rs = db.OpenRecordset("tblUserVersion")
Dim strDest As String
Static acc As Access.Application
Dim dbDataBase As DAO.Database
'checks to see what the current release # is and sets the new release number base on that
CRelease = Right((Left(Thisdb.Name, Len(Thisdb.Name) - 4)), 1)
If CRelease = 0 Then
Release = 1
Else
Release = 0
End If
strSource = MasterDB
strDest = DBLocation & "Maintenance Management" & Release & ".mdb"
ThenQuit = False
If Rs("Version") <> ThisRs("version") Then
DoCmd.Hourglass True
Set fso = New FileSystemObject
fso.CopyFile strSource, strDest, True
ThenQuit = True
DoCmd.Hourglass Flase
'Opens the New updated MMS
Set acc = New Access.Application
acc.Visible = True
Set dbDataBase = acc.DBEngine.OpenDatabase(strDest, False, False, "")
acc.OpenCurrentDatabase strDest
dbDataBase.Close
Set dbDataBase = Nothing
'Closes the old MMS
Call CloseOldMMS
Else
Call DeleteOld
End If
Rs.Close
ThisRs.Close
Set Rs = Nothing
Set ThisRs = Nothing
If ThenQuit = True Then
Set wrkSpace = CreateWorkspace("", "admin", "", "")
Set dbsDataBase = wrkSpace.OpenDatabase(strDest, False)
'MsgBox "MMS has been updated, please restart for changes to take effect", vbOKOnly 'Application.Quit acQuitSaveNone
End If
Exit_Checkupdate:
Exit Function
Err_Checkupdate:
Select Case Err.Number
Case 61
strError = "Floppy disk is full" & vbNewLine & "cannot export mdb"
MsgBox strError, vbCritical, " Disk Full"
Kill strDest
Case 71
strError = "No disk in drive" & vbNewLine & "please insert disk"
MsgBox strError, vbCritical, " No Disk"
Case 13
Call TypeMismatchFix
Case Else
Err.Raise Err.Number, Err.Description
End Select
DoCmd.Hourglass False
Resume Exit_Checkupdate
End Function
Function DBLocation() As String
Dim db As Database
Set db = CurrentDb
DBLocation = Left(db.Name, Len(db.Name) - Len(Dir(db.Name)))
Set db = Nothing
End Function
Function DeleteOld()
On Error GoTo Err_DeleteOld
Dim CRelease As Byte
Dim FileObject As FileSystemObject
Set FileObject = New FileSystemObject
Dim Deldb As Database
Set Deldb = CurrentDb
Dim CurrentData As String
Dim ReleseNum As Byte
CRelease = Right((Left(Deldb.Name, Len(Deldb.Name) - 4)), 1)
ReleseNum = IIf(CRelease = 0, 1, 0)
CurrentData = (Left(Deldb.Name, Len(Deldb.Name) - 5)) & ReleseNum & ".mdb"
If FileObject.FileExists(CurrentData) Then
FileObject.DeleteFile CurrentData
End If
Err_DeleteOld:
'Select Case Err.Number
'Case 53
Exit Function
'Case Else
'Call DeleteOld
'MsgBox Error$ & " #" & Err.Number & " " & Err.Description
'End Select
End Function
Function CloseOldMMS()
Dim CRelease As Byte
Dim ReleseNum As Byte
Static acc As Access.Application
Dim OldDataBase As DAO.Database
Dim OldDMMS As String
Dim Deldb As Database
Set Deldb = CurrentDb
'CRelease = Right((Left(Deldb.Name, Len(Deldb.Name) - 4)), 1)
'ReleseNum = IIf(CRelease = 0, 1, 0)
'OldMMS = (Left(Deldb.Name, Len(Deldb.Name) - 5)) & ReleseNum & ".mdb"
DoCmd.Quit
End Function
Function TypeMismatchFix()
Dim FileObject As FileSystemObject
Dim strDest As String, strSource As String
Static accs As Access.Application
Dim dbDataBas As DAO.Database
Dim DataToDelete As String
Dim ThisCurdb As DAO.Database
Set ThisCurdb = CurrentDb
DataToDelete = ThisCurdb.Name
Set FileObject = New FileSystemObject
Dim IniFile As String
'Copies the correct version of the file
DoCmd.Hourglass True
strDest = DBLocation & "Maintenance Management0.mdb"
strSource = "\\nawespscfs02vb\CommandI\CINCPACFLT\SDNI\CNI-CNRSW\CNRSW_CBHousing\Database\Maintenance Management Master.mdb"
FileObject.CopyFile strSource, strDest, True
'Opens a new window
Set accs = New Access.Application
accs.Visible = True
Set dbDataBas = accs.DBEngine.OpenDatabase(strDest, False, False, "")
accs.OpenCurrentDatabase strDest
dbDataBas.Close
Set dbDataBas = Nothing
'Create INI File with name of Old DB
IniFile = "C:\OldMMS.ini"
FileObject.CreateTextFile IniFile, True, True
WriteINI IniFile, "OldMMS", "LocationName", DataToDelete
'Close Old window
DoCmd.Quit
Set FileObject = Nothing
DoCmd.Hourglass False
End Function
Public Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Public Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long
Public Function GetINI(sINIFile As String, sSection As String, sKey As String, sDefault As String) As String
'Purpose: Returns a value FROM an INI File
'GetINI(Path of INI File, Name of section, Name of Key, Default value if not found)
'Example: GetINI("C:\WINNT\ACROREAD.ini", "AdobeViewer", "MaxApp", "0")
Dim sTemp As String * 256
Dim nLength As Integer
sTemp = Space$(256)
nLength = GetPrivateProfileString(sSection, sKey, sDefault, sTemp, 255, sINIFile)
GetINI = Left$(sTemp, nLength)
End Function
Public Sub WriteINI(sINIFile As String, sSection As String, sKey As String, sValue As String)
'Purpose: Writes value TO an INI File
'GetINI(Path of INI File, Name of Section, Name of Key, Value)
'Example: WriteINI("C:\WINNT\ACROREAD.ini", "AdobeViewer", "AntialiasThreshold", "25")
Dim iCounter As Integer
Dim sTemp As String
sTemp = sValue
'Replace any CR/LF characters with spaces
For iCounter = 1 To Len(sValue)
If Mid$(sValue, iCounter, 1) = vbCr Or Mid$(sValue, iCounter, 1) = vbLf Then Mid$(sValue, iCounter) = " "
Next iCounter
iCounter = WritePrivateProfileString(sSection, sKey, sTemp, sINIFile)
End Sub
Dim IniFile As String, OldMMS As String
IniFile = "C:\OldMMS.ini"
Dim FileObject As FileSystemObject
Set FileObject = New FileSystemObject
OldMMS = GetINI(IniFile, "OldMMS", "LocationName", "0")
'Gets the path of the oldMMS and deletes it
If FileObject.FileExists(OldMMS) Then
FileObject.DeleteFile OldMMS
End If
If FileObject.FileExists(IniFile) Then
FileObject.DeleteFile IniFile
End If
Call DeleteOld
Set FileObject = Nothing