Thanks for the reference. As it happens I already finished my version 1.
It appears I was on a similar vein to your links anyway. I did take one of
the Error messages from one of the links, I thought it was nicely worded.
:O)
My method is simple in that you:
* add the script below to a new module in your current and future front end
databases
* add a CheckUpdate() call to any startup procedure (being in your
'autoexec' macro, in your splash screen or in your switchboard OnOpen event)
* put your future improved FE versions in the same directory with a "_newfe"
tag on the end of the filename
and the rest will happen automatically.
Well, nobody responded to my request for people interested in receiving my
version1, but I'm putting it here anyway. There's too many cool stuff in
there, so I'm not going to explain it.
Feel free to make comments
-------------------------------------------------------------------
Option Compare Database
Option Explicit
' To use this module, call/modify the CheckUpdate routine
Private Declare Function FindExecutable Lib "shell32.dll" Alias _
"FindExecutableA" (ByVal lpFile As String, ByVal lpDirectory As _
String, ByVal lpResult As String) As Long
Private Declare Function apiCopyFile Lib "kernel32" Alias "CopyFileA" _
(ByVal lpExistingFileName As String, _
ByVal lpNewFileName As String, _
ByVal bFailIfExists As Long) As Long
Const cTimeOut = 1000000
Const cFlagName = "Updated"
Function CheckUpdate() As Boolean
'typically update will update automatically when it finds a file with
' _newfe on the end of the filename in the local directory
'however, if you are using a server, I'd suggest
'-use a variable from a server variables table to check latest update
version
'-compare with version on local variables table
'-if server version is higher, then
' -check with user if they want to upgrade
' -if they do want to upgrade then
' -copy any local settings to new _newfe file (close it too)
' -check path to server (probably from table links) to locate new
'_newfe' file
' -copy _newfe file to local directory
' -end if
'-endif
'the rest should look after itself
UpdateDB
End Function
Private Sub UpdateDB(Optional blnConfirm As Boolean)
Dim strFilePath As String
Dim strFilename As String
Dim strFileExtn As String
Dim strMsg As String
Dim lngPos As Long
Dim intCount As Integer
Dim intFileNumber As Integer
strFilePath = CurrentProject.Path
strFilename = CurrentProject.Name
lngPos = InStrRev(strFilename, ".")
strFileExtn = Right(strFilename, Len(strFilename) - lngPos)
strFilename = Left(strFilename, lngPos - 1) ' 1 for dot (extension)
' check if this is the update file, or a working file
If Right(strFilename, 6) = "_newfe" Then
strFilename = Left(strFilename, lngPos - 7) ' 1 for dot, 6 for
'_newfe'
' rename original to backup name
Name strFilePath & "\" & strFilename & "." & strFileExtn As
strFilePath & "\" & strFilename & "_backupfe_" & Format(Now, "yyyymmddhhmm")
& "." & strFileExtn
' copy this file with new filename
CopyFile CurrentDb.Name, strFilePath & "\" & strFilename & "." &
strFileExtn
' Create Flag File
intFileNumber = FreeFile
Open strFilePath & "\" & cFlagName For Output As #intFileNumber
' Open file for output.
Write #intFileNumber, ' Write blank line.
Close #intFileNumber
SwitchDB strFilePath & "\" & strFilename & "." & strFileExtn
Else
' Look for update file
If FileExist(strFilePath & "\" & strFilename & "_newfe." &
strFileExtn) Then
' Check if Update flag file exist
If FileExist(strFilePath & "\" & cFlagName) Then
intCount = 0
Do While (FileExist(strFilePath & "\" & strFilename &
"_newfe.ldb") And (intCount < cTimeOut))
intCount = intCount + 1
Loop
If intCount < cTimeOut Then
Kill strFilePath & "\" & strFilename & "_newfe." &
strFileExtn
Kill strFilePath & "\" & cFlagName
Else
MsgBox "Update Timeout error. If this is the first time
you have seen" _
& " this message then continue. If this message keeps
reoccuring," _
& " then contact the software developer."
If Not FileExist(strFilePath & "\" & strFilename &
"_newfe.lbd") Then
Kill strFilePath & "\" & strFilename & "_newfe." &
strFileExtn
Kill strFilePath & "\" & cFlagName
End If
End If
Else
If blnConfirm Then
strMsg = "You do not have the correct version." & vbCrLf
_
& "Would you like to download the latest client?"
If MsgBox(strMsg, vbExclamation + vbOKCancel, "Update")
= vbOK Then
SwitchDB strFilePath & "\" & strFilename & "_newfe."
& strFileExtn
End If
Else
SwitchDB strFilePath & "\" & strFilename & "_newfe." &
strFileExtn
End If
End If
End If
End If
End Sub
Private Sub SwitchDB(strFilename As String)
Dim strExecutable As String
Dim lngReturn As Long
strExecutable = Space$(128)
lngReturn = FindExecutable(strFilename, "", strExecutable)
' Remove the null at the end of this string
strExecutable = Left$(strExecutable, InStr(strExecutable, Chr$(0)) - 1)
' If an application is found, launch it!
If lngReturn <= 32 Or IsEmpty(strExecutable) Then ' Error
MsgBox "Could not find MS-Access", vbExclamation, "MS-Access Not
Found"
Else
lngReturn = Shell(strExecutable & " """ & strFilename,
vbNormalFocus)
If lngReturn <= 32 Then ' Error
MsgBox "Unable to reopen Database", vbExclamation, "Shell
Failed"
End If
End If
Quit
End Sub
Private Function FileExist(strFile As String) As Boolean
On Error Resume Next
Dim intLength As Integer
intLength = Len(Dir(strFile))
FileExist = (Not Err And intLength > 0)
End Function
Private Sub CopyFile(SourceFile As String, DestFile As String)
'---------------------------------------------------------------
' PURPOSE: Copy a file on disk from one location to another.
' ACCEPTS: The name of the source file and destination file.
' RETURNS: Nothing
' WARNING: The following functions enable you to copy an open file.
' If the source file is changed while the copy operation is in
' process, the destination file may be incomplete or may become corrupted.
'---------------------------------------------------------------
Dim Result As Long
If Dir(SourceFile) = "" Then
MsgBox Chr(34) & SourceFile & Chr(34) & " is not valid file name."
Else
Result = apiCopyFile(SourceFile, DestFile, False)
End If
End Sub
