Microsoft Access VBA Code Snippets

ActiveX Data Objects

Retrieving and processing a recordset works like this

    Dim cn As ADODB.Connection
    Dim rs As ADODB.Recordset
    
    Set cn = CurrentProject.Connection
    Set rs = New ADODB.Recordset
    With rs
        .Open _
            Source:="SELECT * FROM tblTable", _
            ActiveConnection:=cn
        .MoveFirst
        Do While Not .EOF
            'Record based instructions
            .MoveNext
        Loop
        .Close
    End With

modAccess

modAccess consists basically of methods, which are specific to Microsoft Access like methods for retrieving information about properties, checking Access objects for their existence.

getApplicationTitle

    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.

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

setDebug / isDebug

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

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

existsTable

    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

existsQuery

    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

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.

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

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

displayActiveUsers

The usage of the Windows Script Host Object in order to identify the user's workstation is optional.

    Sub displayActiveUsers()
        Dim strUsers As String
        Dim cn As New ADODB.Connection
        Dim rs As New ADODB.Recordset
        Dim wshNet As WshNetwork
    
        strUsers = "Computer Name"
        Set cn = CurrentProject.Connection
        Set rs = cn.OpenSchema( _
            Schema:=adSchemaProviderSpecific, _
            SchemaId:="{947bb102-5d43-11d1-bdbf-00c04fb92675}" _
            )
        Debug.Print _
            rs.Fields(0).Name & " " & _
            rs.Fields(1).Name ' & " " & _
            rs.Fields(2).Name & " " & _
            rs.Fields(3).Name
        Set wshNet = New WshNetwork
        With rs
            Do While Not .EOF
                strUsers = strUsers & vbCrLf & Chr$(149) & "  " & Left(.Fields(0).Value, Len(wshNet.ComputerName))
                If Left(.Fields(0).Value, Len(wshNet.ComputerName)) = wshNet.ComputerName Then
                    strUsers = strUsers & " (me)"
                    Debug.Print _
                        wshNet.ComputerName & "*     " & _
                        wshNet.UserName ' & " " & _
                        .Fields(2).Value & " " & _
                        .Fields(3).Value
                Else
                    Debug.Print _
                        Left(.Fields(0).Value, Len(wshNet.ComputerName)) & "      " & _
                        Trim(.Fields(1).Value) ' & " " & _
                        .Fields(2).Value & " " & _
                        .Fields(3).Value
                End If
                .MoveNext
            Loop
        End With
        MsgBox strUsers, vbOKOnly, "Current Users"
    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

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

removeTempTables

Public Const strPrefixTemp As String = "_"

Public Sub removeTempTables()
    Dim tdf As TableDef
    Dim strTable As String
    
    For Each tdf In CurrentDb.TableDefs
        strTable = tdf.Name
        If Left(strTable, Len(strPrefixTemp)) = strPrefixTemp Then
            setStatus "Removing temporary table '" & strTable & "' ..."
            Debug.Print "Removing temporary table '" & strTable & "' ..."
            DoCmd.DeleteObject acTable, strTable
        End If
    Next
    setStatus
End Sub

removeOldTables

Public Const strPrefixOld As String = "z_"

Public Sub removeOldTables()
    Dim tdf As TableDef
    Dim strTable As String
    
    For Each tdf In CurrentDb.TableDefs
        strTable = tdf.Name
        If Left(strTable, Len(strPrefixOld)) = strPrefixOld Then
            setStatus "Removing old table '" & strTable & "' ..."
            Debug.Print "Removing old table '" & strTable & "' ..."
            DoCmd.DeleteObject acTable, strTable
        End If
    Next
    setStatus
End Sub

modSetting

debugPrintUserRunTimeSettings

    Sub debugPrintUserRunTimeSettings()
        Dim arrSetting() As String
        Dim intIndex As Integer
        
        Debug.Print
        Debug.Print "User RunTime Settings"
        Debug.Print "---------------------"
        On Error GoTo handleGetAllSettingsError
        arrSetting = GetAllSettings(getProjectName, "RunTime")
        On Error GoTo 0
        For intIndex = LBound(arrSetting) To UBound(arrSetting)
            Debug.Print arrSetting(intIndex, 0) & " : " & arrSetting(intIndex, 1)
        Next
        Exit Sub
        
    handleGetAllSettingsError:
        Debug.Print "No user settings available."
    End Sub

deleteUserSettings

    Sub deleteUserSettings()
        Debug.Print
        Debug.Print "User Settings"
        Debug.Print "-------------"
        On Error Resume Next
        DeleteSetting getProjectName
        Debug.Print "All user settings deleted."
    End Sub

modUi

setStatus

    Public Sub setStatus(Optional strMessage As String = "Bereit")
        strMessage = _
            getUserName & " - " & _
            strMessage
        SysCmd acSysCmdSetStatus, strMessage
    End Sub

modFunction

Round2

Microsoft Access' Round() function is different from the one implemented in Microsoft Excel. The behavious can be imitated using a user defined function.

    Public Function Round2(dblValue As Double, intDecimal As Integer) As Double
        Dim dblResult As Double
        
        dblResult = CLng(dblValue * 10 ^ intDecimal) / 10 ^ intDecimal
        
        Round2 = dblResult
    End Function

modSql

Constants

    Public Const strFormatSqlDate As String = "yyyy\-mm\-dd"
    Public Const strFormatSqlDateCriterion As String = "\#yyyy\-mm\-dd\#"

executeSql

Public Function executeSql(strSql As String) As Long
    Dim lngResult As Long
    
    Const strFormatHms As String = "hh:mm:ss"
    
    Dim datStart As Date
    Dim strErr As String
    Dim strTable As String
    Dim strAffected As String
    
    lngResult = 0
    
    If isDebug Then
        Debug.Print "----------------------------------------"
        Debug.Print strSql
        Debug.Print
        datStart = Now
        Debug.Print "Start      : " & Format(datStart, strFormatHms)
    End If

    With CurrentDb
        'DoCmd.SetWarnings False
        On Error GoTo handleExecuteError
        If isDebug Then
            .Execute strSql, dbFailOnError
        Else
            .Execute strSql
        End If
        On Error GoTo 0
        'DoCmd.SetWarnings True
        DoEvents
        
        strAffected = "Records    "
        Select Case .RecordsAffected
        Case 1
            'Last inserted id
            lngResult = .OpenRecordset("SELECT @@IDENTITY")(0)
            If lngResult = 0 Then
                lngResult = 1
            Else
                strAffected = "Last Id    "
            End If
        Case Else
            'Number of affected records
            lngResult = .RecordsAffected
        End Select
    End With
    
    If isDebug Then
        Debug.Print "End        : " & Format(Now, strFormatHms)
        Debug.Print "             " & "--------"
        Debug.Print "Duration   : " & Format(Now - datStart, strFormatHms)
        Debug.Print strAffected & ": " & Format(lngResult, "#,##0")
        Debug.Print "----------------------------------------"
        Debug.Print
    End If

    executeSql = lngResult
    Exit Function
    
handleExecuteError:
    'On Error GoTo handleExecuteSqlErrorFinal
    'DoCmd.RunSQL strSql
    'On Error GoTo 0
    'resume next
    'handleExecuteSqlErrorFinal:

    Select Case Err.Number
    
    Case 3010:
        'Table already exists
        strErr = Err.Description
        strTable = Mid( _
            Err.Description, _
            InStr(1, strErr, "'", vbTextCompare) + 1, _
            InStrRev(strErr, "'", -1, vbTextCompare) - _
                InStr(1, strErr, "'", vbTextCompare) - 1 _
            )
        DoCmd.Close acTable, strTable, acSaveNo
        DoCmd.DeleteObject acTable, strTable
        Resume
    
    Case 2008:
        'Table is open
        DoCmd.Close acTable, strTable, acSaveNo
        Resume
    
    Case Else
        strErr = Err.Number & " : " & Err.Description
        Debug.Print "########################################"
        Debug.Print "# ERR " & Err.Number & " : " & Err.Description
        Debug.Print "# ABORT"
        Debug.Print "########################################"
        Debug.Print
    
    End Select
End Function

showSqlResult

    Public Sub showSqlResult(strSql As String, Optional strQuery As String = "")
        Dim dbs As Database
        Dim qdf As QueryDef
        
        If strQuery = "" Then
            strQuery = "SQL Result"
        End If
        If existsQuery(strQuery) Then
            DoCmd.DeleteObject acQuery, strQuery
        End If
        Set dbs = CurrentDb
        Set qdf = dbs.CreateQueryDef(Name:=strQuery, SQLText:=strSql)
        DoCmd.OpenQuery strQuery
        Do While CurrentData.AllQueries(strQuery).IsLoaded
            DoEvents
        Loop
        DoCmd.DeleteObject acQuery, strQuery
    End Sub

getSqlAmount

    Public Function getSqlAmount(cur As Currency) As String
        Dim strResult As String
        
        strResult = CStr(cur)
        strResult = Replace( _
            Expression:=strResult, _
            Find:=",", _
            Replace:=".", _
            Compare:=vbTextCompare _
            )
        
        getSqlAmount = strResult
    End Function

getSqlDate

    Public Function getSqlDate(dat As Date) As String
        Dim strResult As String
        
        strResult = Format(dat, strFormatSqlDate)
        
        getSqlDate = strResult
    End Function

getSqlDateCriterion

    Public Function getSqlDateCriterion(dat As Date) As String
        Dim strResult As String
        
        strResult = Format(dat, strFormatSqlDateCriterion)
        
        getSqlDateCriterion = strResult
    End Function

modFso

assertPath

    Sub assertPath(strPath)
        Dim fso As FileSystemObject
        Dim blnFirst As Boolean
        
        blnFirst = True
        Set fso = New FileSystemObject
        With fso
            If Not .FolderExists(strPath) Then
                On Error GoTo handleCreateFolderError
                .CreateFolder strPath
                On Error GoTo 0
            End If
        End With
        Exit Sub
        
    handleCreateFolderError:
        If Err.Number = 76 And blnFirst Then
            Debug.Print strPath & " not found - trying to create parent ..."
            assurePath fso.GetParentFolderName(strPath)
            blnFirst = False
            Resume
        Else
            MsgBox "The path '" & strPath & "' could not be found, nor created.", vbExclamation + vbOKOnly
        End If
    End Sub

modWsh

Windows Scripting Host Object based methods

getUserName

    Function getUserName() As String
        Dim strResult As String
        
        Dim wshNet As WshNetwork
        
        Set wshNet = New WshNetwork
        strResult = wshNet.UserName
        
        getUserName = strResult
    End Function

getComputerName

    Function getComputerName() As String
        Dim strResult As String
        
        Dim wshNet As WshNetwork
        
        Set wshNet = New WshNetwork
        strResult = wshNet.ComputerName
        
        getComputerName = strResult
    End Function

modExcel

Variables

    Private xl As Excel.Application
    Private blnCreated As Boolean

getExcel

    Private Function getExcel() As Excel.Application
        If xl Is Nothing Then
            On Error Resume Next
            Set xl = GetObject(, "Excel.Application")
            On Error GoTo 0
            If xl Is Nothing Then
                Set xl = CreateObject("Excel.Application")
                xl.Visible = True
                blnCreated = True
            Else
                blnCreated = False
            End If
        End If
        
        Set getExcel = xl
    End Function

quitExcel

    Sub quitExcel()
        With xl
            If blnCreated Then
                .Quit
            End If
        End With
    End Sub

openExcelWorkbook

    Public Function openExcelWorkbook(strPathFile As String) As Excel.Workbook
        Dim wbkResult As Excel.Workbook
        
        With getExcel
            Set wbkResult = .Workbooks.Open(strPathFile)
        End With
        
        Set openExcelWorkbook = wbkResult
    End Function

closeExcelWorkbook

    Public Sub closeExcelWorkbook(strWorkbook As String, Optional blnQuit As Boolean = False)
        With xl
            .Workbooks(strWorkbook).Close
            If blnQuit Then
                quitExcel
            End If
        End With
    End Sub

applyCorporateStyle

Public Sub applyCorporateStyle(strFile As String)
    Dim fso As FileSystemObject
    
    Dim xls As Excel.Application
    Dim wbk As Workbook
    Dim wks As Worksheet
    Dim rng As Range
    
    Set fso = New FileSystemObject
    
    If Not fso.FileExists(strFile) Then
        MsgBox "The specified file does not exist."
        Exit Sub
    End If
    
    If Not Right(strFile, 4) = ".xls" Then
        MsgBox "The specified file is not a Microsoft Excel file."
        Exit Sub
    End If
    
    Set wbk = openExcelWorkbook(strFile)
    Set xls = wbk.Parent
    
    For Each wks In wbk.Worksheets
        With wks
            .Activate
            'Delete empty sheets
            If .UsedRange.Address = "$A$1" Then
                xls.DisplayAlerts = False
                .Delete
                xls.DisplayAlerts = True
            Else
                'Remove gridlines
                xls.ActiveWindow.DisplayGridlines = False
            
                'Format first row
                Set rng = .UsedRange.Rows(1)
                With rng
                    .Font.Bold = True
                    .Font.Color = vbWhite
                    .Interior.Color = vbRed
                
                    'Enable AutoFilter
                    If wks.AutoFilterMode = False Then
                        .AutoFilter
                    Else
                        .AutoFilter
                        .AutoFilter
                    End If
                
                End With
                
                'Adjust column widths
                .UsedRange.Columns.AutoFit
                
            End If
        End With
    Next
    
    wbk.Save
    wbk.Close
End Sub

modString

getPlainString

Public Function getPrintableString(strSource As String) As String
    Dim strResult As String
    
    Dim intIndex As Integer
    Dim strCharacter As String
    
    strResult = ""
    For intIndex = 1 To Len(strSource)
        strCharacter = Mid(strSource, intIndex, 1)
        Select Case Asc(strCharacter)
        
        ''A - Z, a - z
        'Case 65 To 90, 97 To 122
        '    strResult = strResult & strCharacter
        '
        ''0 - 9
        'Case 48 To 57
        '    strResult = strResult & strCharacter
        '
        ''<space>, <comma>, <hyphen>, <dot>, <slash>
        'Case 20, 44 To 47
        '    strResult = strResult & strCharacter
        
        'ASCII printable characters
        Case 20 To 126
            strResult = strResult & strCharacter
        
        Case Else
            'nothing
        
        End Select
    Next
    
    getPrintableString = strResult
End Function