clsApp: My Application-Wide MS Access Singleton Class Module

Every Microsoft Access application I write includes a class module named clsApp.

I've written several articles about the properties and methods that comprise this class:

.Echo
.Prop
.Environment, .IsDev, .IsTest, .IsProd, .Db, .PgmName
.RegisterTempFile
.TitleBar

As I write additional articles, I will update the list above and the code below accordingly.

Usage

There are two ways to use this class:

Via a global object variable declared in a standard module: Public App As New clsApp
By naming the class App and setting its hidden PredeclaredID attribute to True

In my own code, I use the first method. However, that's mostly for backwards compatibility and consistency with my own codebase. I was not aware of the PredeclaredID approach when I first started using clsApp. By the time I realized it was an option, I had no desire to change all my existing code (or use two different approaches across my codebase).

Additionally, the PredeclaredID approach looks a bit like magic to unsuspecting developers, since the attribute itself is completely hidden in the VBA IDE.

Dependencies

Throw(): raise custom errors with auto-generated deterministic error numbers

The Code

'--== clsApp class module ==--
Option Explicit
Option Compare Database

'RegisterTempFile() declarations:
Private m_collTempFiles As Collection

'Environment() declarations:
Public Enum env__Environment
    env_UNSET
    env_Development
    env_Test
    env_Production
End Enum

Private m_objDB As DAO.Database
Private m_sPgmName As String

'.Echo property declaration:
Private m_bEcho As Boolean

'---------------------------------------------------------------------------------------
' Purpose   : Register a temporary file for cleanup.
' Source    : https://nolongerset.com/app-registertempfile/
' Notes     - The full path to the file must be passed to avoid accidentally deleting the wrong thing.
'           - These files are cleaned up when this class Terminates, usually at program exit.
'           - Changing data sources will also force a cleanup, because clsApp gets re-instantiated.
'---------------------------------------------------------------------------------------
'
Public Sub RegisterTempFile(fpTempFile As String, Optional IgnoreTempFolderCheck As Boolean = False)
    'Validate the data
    If Len(fpTempFile) = 0 Then Exit Sub

    Dim IsFullPath As Boolean
    IsFullPath = (Left(fpTempFile, 2) = "\\") Or (Mid(fpTempFile, 2, 2) = ":\")
    If Not IsFullPath Then Throw "Not a full path: {0}", fpTempFile

    If IsDev() And Not IgnoreTempFolderCheck Then
        'File should be in the temp folder
        Dim IsInTempFolder As Boolean
        Dim foTemp As String  'temp folder
        foTemp = Environ("TEMP")
        IsInTempFolder = fpTempFile Like foTemp & "*"
        If Not IsInTempFolder Then Throw "Temporary files, like {0}, should be saved in the temporary folder: {1}", fpTempFile, foTemp
    End If

    If m_collTempFiles Is Nothing Then Set m_collTempFiles = New Collection

    m_collTempFiles.Add fpTempFile
End Sub

'---------------------------------------------------------------------------------------
' Purpose   : Removes temporary files created by this program and registered via RegisterTempFile.
'---------------------------------------------------------------------------------------
'
Private Function DeleteTempFiles()
    On Error Resume Next
    Dim fpTempFile As Variant
    For Each fpTempFile In m_collTempFiles
        'Extra safeguard to help prevent catastrophe
        Dim HasWildcard As Boolean
        HasWildcard = (InStr(fpTempFile, "*") > 0) Or _
                      (InStr(fpTempFile, "?") > 0)
        If Not HasWildcard Then
            SetAttr fpTempFile, vbNormal  'Remove read-only attribute if it is set
            Kill fpTempFile
        End If
    Next fpTempFile
End Function

'---------------------------------------------------------------------------------------
' Procedure : Environment
' Author    : Mike Wolfe
' Source    : https://nolongerset.com/environmentally-friendly-access/
' Date      : 6/27/2016
' Purpose   : Returns the current environment within which the application is operating.
' Usage     : If App.IsDev Then Debug.Assert LongRunningAssertionTest()
' Notes     - Always returns env_Production unless another environment explicitly set
'           - Settings are by user profile (and, thus, by machine)
'           - On a dev machine, need to call App.Environment = env_Development to get IsDev to return True
'           - Above call can be made from immediate window
'           - Testing fixtures should set App.Environment = env_Test at setup and revert at teardown
'           - Allows, for example, to replace objects with mocks in testing, such as a global logging object
'           - Using the registry means:
'                   o we can force non-Prod environment on users' computers, if we need to
'                   o its less likely to return a false positive than if we used user names or computer names to detect
'                   o is quick and easy to set the environment for developers on any computer
'                   o only needs to be set once per app per profile, not at every startup
'                   o survives code resets when programming state is lost (as opposed to using global vars, etc.)
'---------------------------------------------------------------------------------------
'
Public Property Get Environment() As env__Environment
    Dim EnvAsString As String
    EnvAsString = GetSetting(Me.PgmName, "App", "Environment", "Prod")
    
    'Unless the user's registry is explicitly set to Dev or Test, assume Production
    Select Case EnvAsString
    Case "Dev": Environment = env_Development
    Case "Test": Environment = env_Test
    Case Else: Environment = env_Production
    End Select
End Property
Public Property Let Environment(Value As env__Environment)
    If Value = env_UNSET Then
        DeleteSetting Me.PgmName, "App", "Environment"
    Else
        SaveSetting Me.PgmName, "App", "Environment", EnvToString(Value)
    End If
End Property
Private Function EnvToString(Env As env__Environment) As String
    Select Case Env
    Case env_Development: EnvToString = "Dev"
    Case env_Production: EnvToString = "Prod"
    Case env_Test: EnvToString = "Test"
    End Select
End Function
Public Function IsDev() As Boolean
    IsDev = (Me.Environment = env_Development)
End Function
Public Function IsTest() As Boolean
    IsTest = (Me.Environment = env_Test)
End Function
Public Function IsProd() As Boolean
    IsProd = (Me.Environment = env_Production)
End Function

Public Property Get db() As Database
    Set db = m_objDB
End Property

Public Property Get PgmName() As String
    PgmName = m_sPgmName
End Property
Public Property Let PgmName(Value As String)
    m_sPgmName = Value
    Prop("PgmName") = Value
End Property

'Source : https://nolongerset.com/database-properties-for-thee/
'Purpose: Retrieves a property value stored in the front-end database itself.
'Notes  - If the property has not been set, the DefaultValue is returned instead
'       - However, if no DefaultValue is set either, an error is raised (3270: Property not found)
'       - There are certain property names with special meaning that should not be used for other purposes
'         Reserved property names:
'           - PgmName: the friendly name of the program; if not set, the front-end's filename without extension is used
'           - hg_csv: comma delimited list of tables whose data should be exported by decompose.vbs
Public Property Get Prop(PropName As String, Optional DefaultValue As String = "") As String
    m_objDB.Properties.Refresh
    If Len(DefaultValue) > 0 Then
        On Error Resume Next
        Prop = DefaultValue
    End If
    Prop = m_objDB.Properties(PropName)
End Property

Public Property Let Prop(PropName As String, Optional DefaultValue As String = "", ByVal sProp As String)
Dim P As DAO.Property

    On Error Resume Next
    m_objDB.Properties.Refresh
    m_objDB.Properties(PropName) = sProp
    If Err.Number = 3270 Then    'Property does not exist
        Set P = m_objDB.CreateProperty(PropName, dbText, sProp)
        db.Properties.Append P
    End If
    
End Property

'Source   : https://nolongerset.com/vba-alchemy-turning-methods-into-properties/
Public Property Get Echo() As Boolean
    Echo = m_bEcho
End Property
Public Property Let Echo(ByVal bEcho As Boolean)
    Application.Echo bEcho
    m_bEcho = bEcho
End Property

'Source   : https://nolongerset.com/app-titlebar/
Public Property Get TitleBar() As String
    TitleBar = Me.Prop("AppTitle", "Microsoft Access")
End Property
Public Property Let TitleBar(ByVal sTitleBar As String)
    Me.Prop("AppTitle") = sTitleBar
    Application.RefreshTitleBar
End Property


Private Sub Class_Initialize()
    Set m_objDB = CurrentDb

    Application.Echo True
    m_bEcho = True
    
    Dim DefaultPgmName As String
    DefaultPgmName = Application.CurrentProject.Name
    DefaultPgmName = Left(DefaultPgmName, InStr(DefaultPgmName, ".") - 1)
    m_sPgmName = Prop("PgmName", DefaultPgmName)
End Sub    

Private Sub Class_Terminate()
    Set m_objDB = Nothing
    
    'Remove temp files tracked via RegisterTempFile
    If Not m_collTempFiles Is Nothing Then DeleteTempFiles
End Sub