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

Database Properties

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

setDatabaseProperty

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
    
    If varValue = "" Then
        deleteDatabaseProperty strName
        Exit Function
    End If
    
    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

getDatabaseProperty

Public Function getDatabaseProperty(strName As String) As Variant
    Dim varResult As Variant
    
    Dim dbs As Database
    
    Set dbs = CurrentDb
    varResult = dbs.Properties(strName).Value
    
    getDatabaseProperty = varResult
End Function

deleteDatabaseProperty

Public Sub deleteDatabaseProperty(strName As String)
    Dim dbs As Database
    
    Set dbs = CurrentDb
    On Error Resume Next
    dbs.Properties.Delete strName
    On Error GoTo 0
End Sub

setupDatabaseProperties

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
• modWsh

Code

Public Sub displayActiveConnections()
    Dim strResult As String
    Dim cnn As New ADODB.Connection
    Dim rst As New ADODB.Recordset
    Dim strThisUser As String
    Dim strThisComputer As String
    Dim strUser As String
    Dim strComputer As String

    Set cnn = CurrentProject.Connection
    Set rst = cnn.OpenSchema( _
        Schema:=adSchemaProviderSpecific, _
        SchemaId:="{947bb102-5d43-11d1-bdbf-00c04fb92675}" _
        )
    
    strThisUser = getUserName
    strThisComputer = getComputerName
    With rst
        
        strResult = vbTab & "Computer" & vbTab & vbTab & "User"
        Do While Not .EOF
            
            strComputer = Left(.Fields(0).Value, Len(strThisComputer))
            strUser = Nz(DLookup("User", "tblComputerUser", "Computer='" & strComputer & "'"))
            strResult = strResult & vbCrLf & _
                Chr$(149) & vbTab & strComputer & vbTab & strUser
            If strComputer = strThisComputer Then
                strResult = strResult & vbTab & " <-"
            End If
            
            .MoveNext
        Loop
    End With
    
    MsgBox strResult, vbOKOnly, "Active Connections"
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

Table

getTableLink

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

getTableDatabase

Public Function getTableDatabase(strTable As String) As String
    Dim strResult As String
    
    Const strLinkPrefix As String = ";DATABASE="
    
    Dim strLink As String
    
    strLink = getTableLink(strTable)
    If matchesRegEx(strLink, "^" & strLinkPrefix) Then
        strResult = Mid(strLink, Len(strLinkPrefix) + 1)
    Else
        strResult = ""
    End If
    
    getTableDatabase = strResult
End Function

isSystemTable

Public Function isSystemTable(strTable As String) As Boolean
    Dim blnResult As Boolean
    
    If matchesRegEx(strTable, "^MSys") Then
        blnResult = True
    Else
        blnResult = False
    End If
    
    isSystemTable = blnResult
End Function

isTemporaryTable

Public Function isTemporaryTable(strTable As String) As Boolean
    Dim blnResult As Boolean
    
    If matchesRegEx(strTable, "^~") Then
        blnResult = True
    Else
        blnResult = False
    End If
    
    isTemporaryTable = blnResult
End Function

isLinkedTable

Public Function isLinkedTable(strTable As String) As Boolean
    Dim blnResult As Boolean
    
    Dim strLink As String
    
    strLink = getTableLink(strTable)
    If matchesRegEx(strLink, "^;DATABASE=") Then
        blnResult = True
    Else
        blnResult = False
    End If
    
    isLinkedTable = blnResult
End Function

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

removeTable

Sub removeTable(strTable As String)
    Dim rel As Relation
    
    For Each rel In CurrentDb.Relations
        With rel
            If .Table = strTable Or .ForeignTable = strTable Then
                CurrentDb.Relations.Delete .Name
            End If
        End With
    Next
    DoCmd.DeleteObject acTable, strTable
End Sub

create/removeRelation

Public Sub createRelation(strMasterTable As String, strMasterField As String, strDetailTable As String, strDetailField As String)
    Dim rel As Relation
    Dim fld As Field
    
    Set rel = CurrentDb.createRelation
    With rel
        .Name = Mid(strMasterTable, 4) & "_" & Mid(strDetailTable, 4)
        .Table = strMasterTable
        .ForeignTable = strDetailTable
        .Attributes = dbRelationUpdateCascade Or dbRelationDeleteCascade
        Set fld = .CreateField
        With fld
            .Name = strMasterField
            .ForeignName = strDetailField
        End With
        .Fields.Append fld
    End With
    CurrentDb.Relations.Append rel
End Sub

Public Sub removeRelation(strMasterTable As String, strDetailTable As String)
    CurrentDb.Relations.Delete Mid(strMasterTable, 4) & "_" & Mid(strDetailTable, 4)
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

set / get / remove TableDescription

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

Public Sub removeTableDescription(strTable As String)
    On Error Resume Next
    CurrentDb.TableDefs(strTable).Properties.Delete "Description"
    On Error GoTo 0
End Sub

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

set/remove LinkedTableDescription

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 Sub removeLinkedTableDescription()
    Dim dbs As Database
    Dim tdf As TableDef
    Dim strTableLink As String
    
    Set dbs = CurrentDb
    For Each tdf In dbs.TableDefs
        With tdf
            If Not isSystemTable(.Name) And Not isTemporaryTable(.Name) Then
                setStatus "Removing link description for table '" & .Name & "'"
                removeTableDescription .Name
            End If
        End With
    Next
    setStatus
End Sub

reseedAutoNumber

In some case is might become necessary to reseed the AutoNumber, which means to properly set the next auto-generated number.

Public Sub reseedAutoNumber(strTable As String, strField As String)
    Dim strDatabase As String
    Dim strSql As String
    Dim lngNextAutoNumber As Long
    
    If isLinkedTable(strTable) Then
        strDatabase = getTableDatabase(strTable)
    End If
    lngNextAutoNumber = Nz(DMax(strField, strTable), 0) + 1
    strSql = _
        " ALTER TABLE " & strTable & " " & vbCrLf & _
        "ALTER COLUMN " & strField & " COUNTER(" & lngNextAutoNumber & ",1)"
    executeSql strSql, strDatabase
End Sub

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

createQuery

Public Sub createQuery(strName As String, strSql As String)
    Dim qdf As QueryDef
    
    On Error GoTo handleCreateQueryError
    Set qdf = CurrentDb.CreateQueryDef(strName, strSql)
    On Error GoTo 0
    Application.RefreshDatabaseWindow
    Exit Sub
    
handleCreateQueryError:
    With Err
        Select Case .Number
        Case 3012
            DoCmd.DeleteObject acQuery, strName
            Resume
        Case Else
            Debug.Print "modAccess.createQuery : " & .Number & " : " & .Description
        End Select
    End With
End Sub

deleteQuery

Public Sub deleteQuery(strName As String)
    DoCmd.DeleteObject acQuery, strName
End Sub

Forms

existsForm

Public Function existsForm(strName As String) As Boolean
    Dim blnResult As Boolean

    Dim aob As AccessObject

    blnResult = False
    For Each aob In CurrentProject.AllForms
        If aob.Name = strName Then
            blnResult = True
            Exit For
        End If
    Next
    
    existsForm = blnResult
End Function

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

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

setDefaultAllForms

This function is still under development.

Public Sub setDefaultAllForms()
    Dim obj As AccessObject
    Dim strName As String
    Dim frm As Form
    Dim ctl As Control
    
    For Each obj In CurrentProject.AllForms
        strName = obj.Name
        DoCmd.OpenForm strName, acDesign
        Set frm = Forms(strName)
        setStatus "Defaulting form '" & strName & "' ..."
        With frm
            For Each ctl In .Controls
                With ctl
                    On Error GoTo handleSetFontError
                    .FontName = "Tahoma"
                    .FontSize = 8
                    .SizeToFit
                    On Error GoTo 0
                End With
            Next
            'On Error Resume Next
            'DoCmd.Save acForm, strName
            DoCmd.Close acForm, strName, acSaveYes
            'On Error GoTo 0
        End With
    Next
    setStatus
    Exit Sub
    
handleSetFontError:
    Debug.Print frm.Name & " - " & ctl.Name
    Debug.Print Err.Number & " : " & Err.Description
    Err.Clear
    Resume Next
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

removeDeprecatedObjects

Public Sub removeDeprecatedObjects(Optional blnExecute As Boolean = False, Optional blnMark As Boolean = False)

    'All objects
    removeDeprecated "^[z]?_.*", blnExecute, blnMark
    removeDeprecated "[0-9]{6}", blnExecute, blnMark
    removeDeprecated "_alt[0-9]*$", blnExecute, blnMark
    
    'Specific tables
    removeDeprecatedTables "^~", blnExecute, blnMark
    removeDeprecatedTables "(einfüge|import)fehler", blnExecute, blnMark
    removeDeprecatedTables "^(temp|test)", blnExecute, blnMark
    
    'Specific queries
    removeDeprecatedQueries "^abfrage", blnExecute, blnMark
    
    If Not blnMark Then
        Debug.Print
        Debug.Print _
            "If you would like to mark the above mentioned objects," & vbCrLf & _
            "please run 'removeDeprecatedObjects blnMark:=true'."
    End If
    
    If Not blnExecute Then
        Debug.Print
        Debug.Print _
            "If you would like to delete the above mentioned objects," & vbCrLf & _
            "please run 'removeDeprecatedObjects blnExecute:=true'."
    End If

    If Not blnMark Or Not blnExecute Then
        Debug.Print
        Debug.Print _
            "If you would like to delete only objects 'MARKED FOR DELETION'," & vbCrLf & _
            "please run 'removeDeprecatedObjects blnExecute:=true, blnMark:=true'."
    End If
End Sub

removeDeprecated

Public Sub removeDeprecated(strPattern As String, Optional blnExecute As Boolean = False, Optional blnMark As Boolean = False)
    removeDeprecatedTables strPattern, blnExecute, blnMark
    removeDeprecatedQueries strPattern, blnExecute, blnMark
    'removeForms strPattern, blnExecute
    'removeReports strPattern, blnExecute
End Sub

removeDeprecatedTables

Public Sub removeDeprecatedTables(strPattern As String, Optional blnExecute As Boolean = False, Optional blnMark As Boolean = False)
    Const strInternalPrefix As String = "MSys"
    
    Dim tdf As TableDef
    Dim strTable As String
 
    For Each tdf In CurrentDb.TableDefs
        strTable = tdf.Name
        If _
            Left(strTable, Len(strInternalPrefix)) <> strInternalPrefix And _
            matchesRegEx(strTable, strPattern) _
        Then
            setStatus "Deprecated table '" & strTable & "' ..."
            Debug.Print "Deprecated table '" & strTable & "' ..."
            If blnMark And Not blnExecute Then
                setTableDescription strTable, "MARKED FOR DELETION"
            End If
            If blnExecute Then
                DoCmd.SetWarnings False
                If blnMark Then
                    If getTableDescription(strTable) = "MARKED FOR DELETION" Then
                        DoCmd.DeleteObject acTable, strTable
                    End If
                Else
                    DoCmd.DeleteObject acTable, strTable
                End If
                DoCmd.SetWarnings True
            End If
        End If
    Next
    setStatus
End Sub

removeDeprecatedQueries

Public Sub removeDeprecatedQueries(strPattern As String, Optional blnExecute As Boolean = False, Optional blnMark As Boolean = False)
    Dim qdf As QueryDef
    Dim strQuery As String
 
    For Each qdf In CurrentDb.QueryDefs
        strQuery = qdf.Name
        If matchesRegEx(strQuery, strPattern) Then
            setStatus "Deprecated query '" & strQuery & "' ..."
            Debug.Print "Deprecated query '" & strQuery & "' ..."
            If blnMark And Not blnExecute Then
                setQueryDescription strQuery, "MARKED FOR DELETION"
            End If
            If blnExecute Then
                DoCmd.SetWarnings False
                If blnMark Then
                    If getQueryDescription(strQuery) = "MARKED FOR DELETION" Then
                        DoCmd.DeleteObject acQuery, strQuery
                    End If
                Else
                    DoCmd.DeleteObject acQuery, strQuery
                End If
                DoCmd.SetWarnings True
            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