Microsoft Access VBA Code Snippets

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
    
    getDbAppTitle = strResult
End Function

setDebug

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

isDebug

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

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

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
    
    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 handleExecuteSqlError
        If isDebug Then
            .Execute strSql, dbFailOnError
        Else
            .Execute strSql
        End If
        'On Error GoTo 0
        'DoCmd.SetWarnings True
        DoEvents
        
        Select Case .RecordsAffected
        Case 1
            'Last inserted id
            lngResult = .OpenRecordset("SELECT @@IDENTITY")(0)
        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 "Records    : " & Format(lngResult, "#,##0")
        Debug.Print "----------------------------------------"
        Debug.Print
    End If

    executeSql = lngResult
    'Exit Function
    
'handleExecuteSqlError:
'    On Error GoTo handleExecuteSqlErrorFinal
'    DoCmd.RunSQL strSql
'    On Error GoTo 0
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
    Set qdf = Nothing
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

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