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