Access VBA Version Check Front End

I am going to be splitting an Access database into a Front End (everything except tables) and Back End (tables only). I will put the Back End file on a network share and distribute the Front End file to each user so they have their own copy. When it comes time to update the Front End I would like a message to appear when they open their version to indicate it is out of date and hopefully prevent any access.

I was thinking of creating a table on the Front End and on the Back End that stores the version number of the Front End (e.g. 1.02). Then when I update the version of the Front End in the table on the Back End the old Front Ends will pop up a message and stop working.

So I created the tables and created a query to show the Front End version number in both the Front End version table and the Back End version table. Now how do I auto run this query and pop up a message and stop access when the version numbers are different???

Is there a better way???

Thank you in advance.

1 Answer
1

It is much simpler to use a shortcut to launch the application pulling a fresh copy each time from a networked distribution folder. On a modern network it takes a second or so, and the user will always have an updated and non-bloated copy.

All you need is a script. I wrote up once a full article on how to handle this even in a Citrix environment:

Deploy and update a Microsoft Access application in a Citrix environment

The script establishes two copies of the frontend. That you may not need, thus you can reduce the script somewhat:

Option Explicit

' Launch script for PPT test/development/operation.
' Version 1.3.0
' 2013-09-15
' Cactus Data. Gustav Brock

Const DESKTOP = &H10
Const LOCALAPPDATA = &H1C

Dim objFSO
Dim objAppShell
Dim objDesktopFolder
Dim objLocalAppDataFolder
Dim objLocalFolder
Dim objRemoteFolder

Dim strLocalFolder
Dim strRemoteFolder
Dim strDesktopFolder
Dim strLocalAppDataFolder
Dim strLocalAppDataDsgFolder
Dim strLocalAppDataDsgPptFolder
Dim strDsgSubfolder
Dim strPptSubfolder
Dim strPptAppSubfolder
Dim strPptNcSuffix
Dim strAppName
Dim strAppSuffix
Dim strShortcutName
Dim strAppLocalPath
Dim strAppLocalBackPath
Dim strAppRemotePath
Dim strShortcutLocalPath
Dim strShortcutRemotePath
Dim strRegPath
Dim strRegKey
Dim strRegValue
Dim booNoColour

Dim varValue


' Adjustable parameters.
strDsgSubfolder = "DSG"
strPptSubfolder = "PPT"
strPPtNcSuffix = "NC"
' ---------------------------------------------------------------------------------
' Uncomment one folder name only:
'strPptAppSubfolder = "Development"
strPptAppSubfolder = "Operations"
'strPptAppSubfolder = "Test"
' ---------------------------------
' Indicate if the script is for the normal version (0) or the no-colour version (1):
booNoColour = 0
' ---------------------------------------------------------------------------------
strRemoteFolder = "K:_SharedSales PlanningEnvironments" & strPptAppSubfolder
If booNoColour = 1 Then
strAppSuffix = strPptNcSuffix
Else
strAppSuffix = ""
End If
strAppName = "SalesPlanningTool" & strAppSuffix & ".accdb"
If strPptAppSubfolder = "Operations" Then
If strAppSuffix = "" Then
strShortcutName = "RunPPT.lnk"
Else
strShortcutName = "RunPPT " & strAppSuffix & ".lnk"
End If
Else
If strAppSuffix = "" Then
strShortcutName = "RunPPT " & strPptAppSubfolder & ".lnk"
Else
strShortcutName = "RunPPT " & strAppSuffix & " " & strPptAppSubfolder & ".lnk"
End If
End If

' Enable simple error handling.
On Error Resume Next

' Find user's Desktop and AppDataLocal folder.
Set objAppShell = CreateObject("Shell.Application")
Set objDesktopFolder = objAppShell.Namespace(DESKTOP)
strDesktopFolder = objDesktopFolder.Self.Path
Set objLocalAppDataFolder = objAppShell.Namespace(LOCALAPPDATA)
strLocalAppDataFolder = objLocalAppDataFolder.Self.Path

' Dynamic parameters.
strLocalAppDataDsgFolder = strLocalAppDataFolder & "" & strDsgSubfolder
strLocalAppDataDsgPptFolder = strLocalAppDataDsgFolder & "" & strPptSubfolder
strLocalFolder = strLocalAppDataDsgPptFolder & "" & strPptAppSubfolder
strAppLocalPath = strLocalFolder & "" & strAppName
strShortcutLocalPath = strDesktopFolder & "" & strShortcutName

' Permanent parameters.
strAppRemotePath = strRemoteFolder & "" & strAppName
strShortcutRemotePath = strRemoteFolder & "" & strShortcutName

' Create the File System Object.
Set objFSO = CreateObject("Scripting.FileSystemObject")

If Not objFSO.FolderExists(strRemoteFolder) Then
Call ErrorHandler("No access to " & strRemoteFolder & ".")
Else
Set objRemoteFolder = objFSO.GetFolder(strRemoteFolder)
' If local folder does not exist, create the folder.
If Not objFSO.FolderExists(strLocalFolder) Then
If Not objFSO.FolderExists(strLocalAppDataDsgFolder) Then
Set objLocalFolder = objFSO.CreateFolder(strLocalAppDataDsgFolder)
If Not Err.Number = vbEmpty Then
Call ErrorHandler("Folder " & strLocalAppDataDsgFolder & " could not be created.")
End If
End If
If Not objFSO.FolderExists(strLocalAppDataDsgPPtFolder) Then
Set objLocalFolder = objFSO.CreateFolder(strLocalAppDataDsgPptFolder)
If Not Err.Number = vbEmpty Then
Call ErrorHandler("Folder " & strLocalAppDataDsgPptFolder & " could not be created.")
End If
End If
If Not objFSO.FolderExists(strLocalFolder) Then
Set objLocalFolder = objFSO.CreateFolder(strLocalFolder)
If Not Err.Number = vbEmpty Then
Call ErrorHandler("Folder " & strLocalFolder & " could not be created.")
End If
End If
End If
Set objLocalFolder = objFSO.GetFolder(strLocalFolder)
End If

If Not objFSO.FileExists(strAppRemotePath) Then
Call ErrorHandler("The application file:" & vbCrLf & strAppRemotePath & vbCrLF & "could not be found.")
Else
' Close a running PPT.
Call KillTask("PPT")
' Wait while TaskKill is running twice to close the instance(s) of PPT and PPT Background.
Call AwaitProcess("taskkill.exe")
Call KillTask("PPT Background")
' Wait while TaskKill is running twice to close the instance(s) of PPT and PPT Background.
Call AwaitProcess("taskkill.exe")

' Copy app to local folder.
If objFSO.FileExists(strAppLocalPath) Then
objFSO.DeleteFile(strAppLocalPath)
If Not Err.Number = 0 Then
Call ErrorHandler("The application file:" & vbCrLf & strAppName & vbCrLF & "can not be refreshed/updated. It may be in use.")
End If
End If
If objFSO.FileExists(strAppLocalPath) Then
Call ErrorHandler("The local application file:" & vbCrLf & strAppLocalPath & vbCrLF & "could not be replaced.")
Else
objFSO.CopyFile strAppRemotePath, strAppLocalPath
If Not Err.Number = vbEmpty Then
Call ErrorHandler("Application could not be copied to " & strLocalFolder & ".")
End If
' Create copy for PPT Background.
strAppLocalBackPath = Replace(Replace(strAppLocalPath, ".accdb", ".accbg"), "SalesPlanningTool", "SalesPlanningToolBack")
objFSO.CopyFile strAppLocalPath, strAppLocalBackPath
If Not Err.Number = vbEmpty Then
Call ErrorHandler("Background application could not be copied to " & strLocalFolder & ".")
End If
End If

' Copy shortcut.
objFSO.CopyFile strShortcutRemotePath, strShortcutLocalPath
If Not Err.Number = vbEmpty Then
Call ErrorHandler("Shortcut could not be copied to your Desktop.")
End If
End If

' Write Registry entries for Access security.
strRegKey = "HKEY_CURRENT_USERSoftwareMicrosoftOffice14.0AccessSecurity"
strRegValue = "VBAWarnings"
strRegPath = strRegKey & strRegValue
varValue = 1
Call WriteRegistry(strRegPath, varValue,"REG_DWORD")

strRegKey = strRegKey & "Trusted LocationsLocationLocalAppData"
strRegValue = "AllowSubfolders"
strRegPath = strRegKey & strRegValue
varValue = 1
Call WriteRegistry(strRegPath, varValue, "REG_DWORD")

strRegValue = "Date"
strRegPath = strRegKey & strRegValue
varValue = Now
varValue = FormatDateTime(varValue, vbShortDate) & " " & FormatDateTime(varValue, vbShortTime)
Call WriteRegistry(strRegPath, varValue, "REG_SZ")

strRegValue = "Description"
strRegPath = strRegKey & strRegValue
varValue = "Local AppData"
Call WriteRegistry(strRegPath, varValue, "REG_SZ")

strRegValue = "Path"
strRegPath = strRegKey & strRegValue
varValue = strLocalAppDataFolder & ""
Call WriteRegistry(strRegPath, varValue, "REG_SZ")

' Run PPT.
If objFSO.FileExists(strAppLocalPath) Then
Call RunApp(strAppLocalPath, False)
Else
Call ErrorHandler("The local application file:" & vbCrLf & strAppLocalPath & vbCrLF & "could not be found.")
End If

Set objRemoteFolder = Nothing
Set objLocalFolder = Nothing
Set objLocalAppDataFolder = Nothing
Set objDesktopFolder = Nothing
Set objAppShell = Nothing
Set objFSO = Nothing

WScript.Quit


' Supporting subfunctions
' -----------------------

Sub RunApp(ByVal strFile, ByVal booBackground)

Dim objShell
Dim intWindowStyle

' Open as default foreground application.
intWindowStyle = 1

Set objShell = CreateObject("WScript.Shell")
objShell.Run Chr(34) & strFile & Chr(34), intWindowStyle, False
Set objShell = Nothing

End Sub


Sub KillTask(ByVal strWindowTitle)

Dim objShell

Set objShell = CreateObject("WScript.Shell")
objShell.Run "TaskKill.exe /FI ""WINDOWTITLE eq " & strWindowTitle & """", 7, False
Set objShell = Nothing

End Sub


Sub AwaitProcess(ByVal strProcess)

Dim objSvc
Dim strQuery
Dim colProcess
Dim intCount

Set objSvc = GetObject("winmgmts:rootcimv2")
strQuery = "select * from win32_process where name='" & strProcess & "'"

Do
Set colProcess = objSvc.Execquery(strQuery)
intCount = colProcess.Count
If intCount > 0 Then
WScript.Sleep 300
End If
Loop Until intCount = 0

Set colProcess = Nothing
Set objSvc = Nothing

End Sub


Sub WriteRegistry(ByVal strRegPath, ByVal varValue, ByVal strRegType)
' strRegType should be:
' "REG_SZ" for a string
' "REG_DWORD" for an integer
' "REG_BINARY" for a binary or boolean
' "REG_EXPAND_SZ" for an expandable string

Dim objShell

Set objShell = CreateObject("WScript.Shell")

Call objShell.RegWrite(strRegPath, varValue, strRegType)

Set objShell = Nothing

End Sub


Sub ErrorHandler(Byval strMessage)

Set objRemoteFolder = Nothing
Set objLocalFolder = Nothing
Set objLocalAppDataFolder = Nothing
Set objDesktopFolder = Nothing
Set objAppShell = Nothing
Set objFSO = Nothing
WScript.Echo strMessage
WScript.Quit

End Sub


By clicking "Post Your Answer", you acknowledge that you have read our updated terms of service, privacy policy and cookie policy, and that your continued use of the website is subject to these policies.