INTELLIGENT WORK FORUMS
FOR COMPUTER PROFESSIONALS

Log In

Come Join Us!

Are you a
Computer / IT professional?
Join Tek-Tips Forums!
  • Talk With Other Members
  • Be Notified Of Responses
    To Your Posts
  • Keyword Search
  • One-Click Access To Your
    Favorite Forums
  • Automated Signatures
    On Your Posts
  • Best Of All, It's Free!

*Tek-Tips's functionality depends on members receiving e-mail. By joining you are opting in to receive e-mail.

Posting Guidelines

Promoting, selling, recruiting, coursework and thesis posting is forbidden.

Jobs

Multi User Databases

Ensuring that everyone has the current Front end and doesnt change the filename by shaiss
Posted: 20 Apr 04

I've read the two FAQs posted here and searched on the net for ideas.  Basically, the two here didnt work, plus, why rely on VB scripting, and what if you dont have access to the startup folder.  this is my solution.  All done from within Access.  The DB opens and compares its version to the version # in the master front end and executes the module based on that.  Theres only one excption.  One of the users of my database is destructive and likes to change the file name and customize his icon.  Well no more.  This code takes that file, deletes it and copies the new one from the server.  It uses a temporary ini file to store that file name so it can delete it later.  You will need to set some referances inorder for this to work. DOA, Microsoft Scripting Runtime (maybe, i get mixed results when i turn this off), ADO, OLE Automation (im not sure about this one), Visual Basic for Applications (not sure again).  Im not sure about some of these because ive tested so many ideas that i dont wat to take the chance and turn them off.  Just turn on DOA.  That should be it, if there are others experiment and let me know.  Thanks.  The next version of this will be to copy the mde from the server rather than the mdb.

Create a new module with the following code and call it modCheckUpdate:

CODE

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

Create another module named modCopyToINI and copy this code.  This is the trick behind storeing that modified file name.

CODE

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
Now, if you have a switchboard, put the following code in the OnClose event.  Dont put it on an Exit button because what if the User closes the database with the X or File->Exit.  Just put it in the OnClose.

CODE

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

Back to Microsoft: Access Modules (VBA Coding) FAQ Index
Back to Microsoft: Access Modules (VBA Coding) Forum

My Archive

Resources

Close Box

Join Tek-Tips® Today!

Join your peers on the Internet's largest technical computer professional community.
It's easy to join and it's free.

Here's Why Members Love Tek-Tips Forums:

Register now while it's still free!

Already a member? Close this window and log in.

Join Us             Close