Microsoft Access modAccess

Application, Project, Database

getApplicationTitle

Public Function getApplicationTitle() As String
    Dim strResult As String
    
    strResult = CurrentDb.Properties("AppTitle").Value
    
    getApplicationTitle = strResult
End Function

getProjectName

The first guess for this is usually CurrentProject.Name but unfortunately this just returns the name of the file. If you want to bind your settings to a certain project, you certainly don't want to rely on the exact naming of a file; to the contrary you want to be able to use your stored settings no matter what the database file is named.

Public Function getProjectName() As String
    Dim strResult As String
    
    strResult = Application.VBE.ActiveVBProject.Name
    
    getProjectName = strResult
End Function

setDatabaseProperty / setupDatabaseProperties

Public Function setDatabaseProperty( _
    strName As String, _
    varType As Variant, _
    varValue As Variant _
    ) As Boolean
    Dim blnResult As Boolean
    
    Dim dbs As Database
    Dim prp As Property
    
    Set dbs = CurrentDb
    On Error GoTo handleSetDatabasePropertyError
    dbs.Properties(strName) = varValue
    blnResult = True
    
    setDatabaseProperty = blnResult
    Exit Function
    
handleSetDatabasePropertyError:
    If Err.Number = 3270 Then
        'Property not found
        Set prp = dbs.CreateProperty(strName, varType, varValue)
        dbs.Properties.Append prp
        Resume Next
     Else
        'Unknown error
        blnResult = False
     End If
End Function

See the Microsoft Access Database Properties for a list of all available options.

Public Sub setupDatabaseProperties()
    'Application
    setDatabaseProperty "AppTitle", dbText, getProject
    setDatabaseProperty "AppIcon", dbText, "d:\project\appicon.ico"

    'Startup
    setDatabaseProperty "StartupForm", dbText, "frmMain"
    setDatabaseProperty "StartupShowDbWindow", dbBoolean, False
    setDatabaseProperty "StartupShowStatusBar", dbBoolean, True

    'Allowance
    setDatabaseProperty "AllowFullMenus", dbBoolean, True
    setDatabaseProperty "AllowBuiltinToolbars", dbBoolean, True
    setDatabaseProperty "AllowToolbarChanges", dbBoolean, False
    setDatabaseProperty "AllowShortcutMenus", dbBoolean, True
    setDatabaseProperty "AllowBreakIntoCode", dbBoolean, True
    setDatabaseProperty "AllowSpecialKeys", dbBoolean, True
    setDatabaseProperty "AllowBypassKey", dbBoolean, True
End Sub

displayActiveConnections

Description

The active connections are listed in the direct window and in a message box. The record set returns four fields:

• 0 – COMPUTER_NAME, name of the workstation
• 1 – LOGIN_NAME, in a secured database it will return the login name of the user, otherwise it will be 'Admin'.
• 2 – CONNECTED, 'true' (-1), if there is an entry in the LDB file.
• 3 – SUSPECTED_STATE, 'true' (-1), if the database was left in a "suspect" state, otherwise it will be 'Null'.

The most important information is COMPUTER_NAME, as the mileage may vary depending on the type and implementation of the database. Therefore only this information will be debugged and displayed in a message box.

Requirements

• Microsoft ActiveX Data Objects 2.5 Library
• Windows Script Host Object Model

Code

'Required : Microsoft ActiveX Data Objects 2.5 Library
'Required : Windows Script Host Object Model
Public Sub displayActiveConnections()
    Dim strUsers As String
    Dim cn As New ADODB.Connection
    Dim rs As New ADODB.Recordset
    Dim wshNet As WshNetwork
    Dim strWorkstation As String

    strUsers = "Workstation"
    Set cn = CurrentProject.Connection
    Set rs = cn.OpenSchema( _
        Schema:=adSchemaProviderSpecific, _
        SchemaId:="{947bb102-5d43-11d1-bdbf-00c04fb92675}" _
        )
    Debug.Print rs.Fields(0).Name
    Set wshNet = New WshNetwork
    With rs
        Do While Not .EOF
            strWorkstation = Left(.Fields(0).Value, Len(wshNet.ComputerName))
            If strWorkstation = wshNet.ComputerName Then
                strWorkstation = strWorkstation & " (me)"
            End If
            strUsers = strUsers & vbCrLf & _
                Chr$(149) & "  " & strWorkstation
            Debug.Print strWorkstation
            .MoveNext
        Loop
    End With
    MsgBox strUsers, vbOKOnly, "Current Users"
End Sub

Debug

setDebug / isDebug

Public Sub setDebug(blnDebug As Boolean)
    saveSetting getProjectName, "RunTime", "Debug", CStr(blnDebug)
End Sub

Public Function isDebug() As Boolean
    Dim blnResult As Boolean
    
    blnResult = CBool(GetSetting(getProjectName, "RunTime", "Debug", 0))
    
    isDebug = blnResult
End Function

inList

Public Function inList(cmb As ComboBox, var As Variant) As Boolean
    Dim blnResult As Boolean
    Dim intIndex As Integer
    
    blnResult = False
    With cmb
        For intIndex = Abs(.ColumnHeads) To .ListCount - 1
            If CLng(.ItemData(intIndex)) = CLng(Nz(var)) Then
                blnResult = True
                Exit For
            End If
        Next
    End With
    
    inList = blnResult
End Function

Table

existsTable

Public Function existsTable(strTable As String) As Boolean
    Dim blnResult As Boolean
    Dim tdf As TableDef
    
    blnResult = False
    For Each tdf In CurrentDb.TableDefs
        If tdf.Name = strTable Then
            blnResult = True
            Exit For
        End If
    Next
    
    existsTable = blnResult
End Function

setTableFieldType

Public Sub setTableFieldType(strTable As String, strField As String, strType As String)
    Dim strSql As String
 
    strSql = _
        "ALTER TABLE " & strTable & " ALTER COLUMN " & strField & " " & strType
    executeSql strSql
End Sub

setTableFieldFormat

Public Sub setTableFieldFormat(strTable As String, strField As String, strFormat As String)
    Dim db As Database
    Dim tdf As TableDef
    Dim fld As Field
    Dim prp As Property
    
    Set db = CurrentDb
    Set tdf = db.TableDefs(strTable)
    Set fld = tdf.Fields(strField)
    On Error GoTo handleSetTableFieldFormatError
    fld.Properties("Format") = strFormat
    On Error GoTo 0
    tdf.Fields.Refresh
    Exit Sub
    
handleSetTableFieldFormatError:
    If Err.Number = 3270 Then
        fld.Properties.Append tdf.CreateProperty("Format", dbText, strFormat)
    End If
    Resume Next
End Sub

setTableDescription / getTableDescription

The property "Description" is not initially present in a table definition. Therefore it has to be created and appended to the property collection of the table definition on first usage.

Public Sub setTableDescription(strTable As String, strDescription As String)
    Dim dbs As Database
    Dim tdf As TableDef
    Dim prp As Property
    
    Set dbs = CurrentDb
    Set tdf = dbs.TableDefs(strTable)
    
    On Error GoTo handleSetTableDescriptionError
    tdf.Properties("Description").Value = strDescription
    On Error GoTo 0
    Exit Sub
    
handleSetTableDescriptionError:
    If Err.Number = 3270 Then
        Set prp = tdf.CreateProperty("Description", dbText, strDescription)
        tdf.Properties.Append prp
        Resume Next
    Else
        MsgBox Err.Number & ": " & Err.Description
    End If
End Sub

Public Function getTableDescription(strTable As String) As String
    Dim strResult As String

    On Error Resume Next
    strResult = CurrentDb.TableDefs(strTable).Properties("Description").Value
    On Error GoTo 0
    
    getTableDescription = strResult
End Function

linkTable

Public Sub linkTable( _
    strTable As String, _
    strFilePath As String, _
    Optional strTableSource As String = "" _
    )
    Dim dbs As Database
    Dim tdf As TableDef
    
    If strTableSource = "" Then
        strTableSource = strTable
    End If
    
    setStatus "Linking table '" & strTable & "' to " & strFilePath & " (" & strTableSource & ") ..."
    Set dbs = CurrentDb
    If existsTable(strTable) Then
        DoCmd.DeleteObject acTable, strTable
    End If
    Set tdf = dbs.CreateTableDef(strTable)
    With tdf
        .Connect = ";DATABASE=" & strFilePath
        .SourceTableName = strTableSource
    End With
    dbs.TableDefs.Append tdf
    setTableDescription strTable, strFilePath
    setStatus
End Sub

setLinkedTableDescription / getTableLink

Public Sub setLinkedTableDescription()
    Dim dbs As Database
    Dim tdf As TableDef
    Dim strTableLink As String
    
    Set dbs = CurrentDb
    For Each tdf In dbs.TableDefs
        With tdf
            setStatus "Setting link description for table '" & .Name & "'"
            strTableLink = getTableLink(.Name)
            strTableLink = Replace(strTableLink, ";DATABASE=", "")
            If strTableLink <> "" Then
                setTableDescription .Name, strTableLink
            End If
        End With
    Next
    setStatus
End Sub

Public Function getTableLink(strTable As String) As String
    Dim strResult As String
    
    strResult = CurrentDb.TableDefs(strTable).Connect
    
    getTableLink = strResult
End Function

turnOffSubDataSheets

Public Sub turnOffSubDataSheets()
    Dim db As Database
    Dim tdf As TableDef
    Dim prp As Property
    Dim strProperty As String
    Dim strValueRight As String
    Dim strValueWrong As String
    
    setStatus "Removing sub data sheets ..."
    Set db = CurrentDb
    strProperty = "SubDataSheetName"
    strValueRight = "[None]"
    strValueWrong = "[Auto]"
    
    For Each tdf In db.TableDefs
        With tdf
            If (.Attributes And dbSystemObject) = 0 Then
                On Error GoTo handlePropertyError
                If .Properties(strProperty).Value = strValueWrong Then
                    setStatus "Removing sub data sheets " & .Name & " ..."
                    .Properties(strProperty).Value = strValueRight
                    setStatus "Removing sub data sheets ..."
                End If
                On Error GoTo 0
            End If
        End With
    Next
    db.Close
    setStatus
    Exit Sub
    
handlePropertyError:
    With Err
        If .Number = 3270 Then
            Set prp = tdf.CreateProperty(strProperty)
            prp.Type = 10
            prp.Value = strValueRight
            tdf.Properties.Append prp
        Else
            Debug.Print .Number & " : " & .Description
        End If
        .Clear
    End With
    Resume Next
End Sub

Query

existsQuery

Public Function existsQuery(strQuery As String) As Boolean
    Dim blnResult As Boolean
    Dim qdf As QueryDef
    
    blnResult = False
    For Each qdf In CurrentDb.QueryDefs
        If qdf.Name = strQuery Then
            blnResult = True
            Exit For
        End If
    Next
    
    existsQuery = blnResult
End Function

Forms

updateForms

This method is used to reflect global changes in all open forms. The error handling is necessary in case a corresponding method should be missing.

Public Sub updateForms()
    Dim aob As AccessObject
    
    For Each aob In CurrentProject.AllForms
        With aob
            If .IsLoaded Then
                On Error Resume Next
                Forms.Item(.Name).updateForm
                On Error GoTo 0
            End If
        End With
    Next
End Sub

In order to use this, two prerequisites must be met, which will be illustrated using a combo box which display a customer (cmbCustomer) and should reflect changes of a globally stored customer id (using setCustomerId / getCustomerId, for example):

• the changing procedure must call updateForms after the value has been changed

Private Sub cmbCustomer_AfterUpdate()
    setCustomerId cmbCustomer.Value
    updateForms
End Sub

• every form, which uses the customer id, must have a public method "updateForm" which is responsible for reflecting the change in the form (or report).

Public Sub updateForm()
    cmbCustomer.Value = getCustomerId
End Sub

Consistency

displayGaps

Public Sub displayGaps( _
    strTable As String, _
    Optional strField As String = "Id", _
    Optional lngStart = 1, _
    Optional lngEnd = -1, _
    Optional lngLength = -1, _
    Optional lngCount = -1 _
    )

    Dim strTableMissing As String
    Dim strSql As String
    
    strTableMissing = "_" & strTable & "_Missing_" & strField
    strSql = _
        "   SELECT Current.Id - 1      AS MissingId             " & vbCrLf & _
        "     INTO " & strTableMissing & "                      " & vbCrLf & _
        "     FROM " & strTable & "    AS [Current]             " & vbCrLf & _
        "LEFT JOIN " & strTable & "    AS Previous              " & vbCrLf & _
        "       ON Current.Id           = Previous.Id + 1       " & vbCrLf & _
        "    WHERE Current.Id           > " & lngStart + 1 & "  " & vbCrLf & _
        "      AND Previous.Id         IS NULL                  "
    If lngEnd <> -1 Then
        strSql = strSql & _
            "      AND Current.Id           < " & lngEnd + 1 & "    "
    End If
    If lngCount <> -1 Then
        strSql = Replace(strSql, "SELECT", "SELECT TOP " & lngCount)
    End If
    executeSql strSql
    
    DoCmd.OpenTable strTableMissing
End Sub

removeDeprecatedObjects

Public Sub removeDeprecatedObjects(Optional blnExecute As Boolean = False)
    'All objects
    removeObjects "^[z]?_.*", blnExecute
    removeObjects "[0-9]{6}", blnExecute
    removeObjects "_alt[0-9]*$", blnExecute
    
    'Specific tables
    removeTables "(einfüge|import)fehler", blnExecute
    removeTables "^(temp|test)", blnExecute
    
    'Specific queries
    removeQueries "^abfrage", blnExecute
    
    'Specific forms
    
    'Specific reports
    
    If Not blnExecute Then
        Debug.Print
        Debug.Print _
            "If you would like to delete the above mentioned objects," & vbCrLf & _
            "please run 'removeDeprecatedObjects true'."
    End If
End Sub

removeObjects

Public Sub removeObjects(strPattern As String, Optional blnExecute As Boolean = False)
    removeTables strPattern, blnExecute
    removeQueries strPattern, blnExecute
    removeForms strPattern, blnExecute
    removeReports strPattern, blnExecute
End Sub

removeTables

Public Sub removeTables(strPattern As String, Optional blnExecute As Boolean = False)
    Dim tdf As TableDef
    Dim strTable As String
 
    For Each tdf In CurrentDb.TableDefs
        strTable = tdf.Name
        If matches(strTable, strPattern) Then
            setStatus "Removing table '" & strTable & "' ..."
            Debug.Print "Removing table '" & strTable & "' ..."
            If blnExecute Then
                DoCmd.DeleteObject acTable, strTable
            End If
        End If
    Next
    setStatus
End Sub

removeQueries

Public Sub removeQueries(strPattern As String, Optional blnExecute As Boolean = False)
    Dim qdf As QueryDef
    Dim strQuery As String
 
    For Each qdf In CurrentDb.QueryDefs
        strQuery = qdf.Name
        If matches(strQuery, strPattern) Then
            setStatus "Removing query '" & strQuery & "' ..."
            Debug.Print "Removing query '" & strQuery & "' ..."
            If blnExecute Then
                DoCmd.DeleteObject acQuery, strQuery
            End If
        End If
    Next
    setStatus
End Sub

removeForms

Public Sub removeForms(strPattern As String, Optional blnExecute As Boolean = False)
    Dim afs As AllForms
    Dim aob As AccessObject
    Dim strForm As String
 
    Set afs = CurrentProject.AllForms
    For Each aob In afs
        strForm = aob.Name
        If matches(strForm, strPattern) Then
            setStatus "Removing Form '" & strForm & "' ..."
            Debug.Print "Removing Form '" & strForm & "' ..."
            If blnExecute Then
                DoCmd.DeleteObject acForm, strForm
            End If
        End If
    Next
    setStatus
End Sub

removeReports

Public Sub removeReports(strPattern As String, Optional blnExecute As Boolean = False)
    Dim arp As AllReports
    Dim aob As AccessObject
    Dim strReport As String
 
    Set arp = CurrentProject.AllReports
    For Each aob In arp
        strReport = aob.Name
        If matches(strReport, strPattern) Then
            setStatus "Removing Report '" & strReport & "' ..."
            Debug.Print "Removing Report '" & strReport & "' ..."
            If blnExecute Then
                DoCmd.DeleteObject acReport, strReport
            End If
        End If
    Next
    setStatus
End Sub