This is a little VB program that checks the version on the server, and copies it down to the PC if a newer version
is available. I use a table named Setup with a field named Item that holds a version number like: 20000907-1851
which means Sep 7, 2000 at 6:51 PM. Originally, we would ask if they wanted the new version, but we took that out.
The user's shortcut runs this program to open the database. If a newer version is available, it renames the local
copy in the style "HTyymmdd..MDB" instead of just deleting it.
Sub Main() ' HTFS.EXE 5/11/2000 ' 7/3/00 change server path ' Bill Mitchell wvmitchell@compuserve.com Const NetPath = "F:\ACCESS\HTFS\" Const LocalPath = "C:\HTFS\" Const MyDB = "HTFS_USA.MDB" Const MyLDB = "HTFS_USA.LDB" Const MSA = "C:\Program Files\Microsoft Office\Office\msaccess.exe " ' Dim db As Database, rst As Recordset Dim s As String, t As String, resp Dim OldStyleName As String, LocalVersion As String, NetVersion As String ' 7/10/00 prevent multiple instances s = Dir(LocalPath & MyLDB, vbNormal) If Len(s) <> 0 Then ' 8/7/00 try to delete the ldb ' in case we crashed and it was left behind On Error Resume Next Kill LocalPath & MyLDB If Err.Number = 75 Then MsgBox Err.Description, vbInformation, "Error # " & Err.Number t = "You already have the HTFS database open." & vbCrLf & vbCrLf t = t & "Check the Windows taskbar at the bottom of the screen, " & vbCrLf t = t & "and click on the Microsoft Access icon." & vbCrLf & vbCrLf t = t & "If you need help, call your supervisor." MsgBox t, vbExclamation, "HTFS IS RUNNING" Exit Sub End If End If ' On Error GoTo err_main s = "SELECT Item FROM Setup WHERE ID=9" ' get rev # from local file Set db = OpenDatabase(LocalPath & MyDB) Set rst = db.OpenRecordset(s) If Not (rst.BOF And rst.EOF) Then rst.MoveFirst LocalVersion = rst!Item End If rst.Close Set rst = Nothing db.Close ' get rev # from server file Set db = OpenDatabase(NetPath & MyDB) Set rst = db.OpenRecordset(s) If Not (rst.BOF And rst.EOF) Then rst.MoveFirst NetVersion = rst!Item End If rst.Close Set rst = Nothing db.Close If Len(LocalVersion) > 0 And Len(NetVersion) > 0 Then If NetVersion > LocalVersion Then ' 7/10/00 don't ask, just do it 's = "There is a newer version on the server. Do you want to download it?" 'resp = MsgBox(s, vbYesNo + vbQuestion + vbDefaultButton1, "VERSION") 'If resp = vbYes Then ' rename the existing file in the old style, like 'HT000511' OldStyleName = "HT" & Mid(LocalVersion, 3, 6) & ".MDB" ' delete any existing "old name" file If Dir(LocalPath & OldStyleName) <> "" Then Kill LocalPath & OldStyleName End If Name LocalPath & MyDB As LocalPath & OldStyleName FileCopy NetPath & MyDB, LocalPath & MyDB 'End If End If End If Shell MSA & LocalPath & MyDB, vbMaximizedFocus exit_main: Exit Sub ' err_main: s = "Cannot copy file - please try later." & vbCrLf & vbCrLf & Err.Description MsgBox s, vbCritical, "ERROR CODE: " & Err.Number Resume exit_main ' End Sub