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

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

modFso

assurePath

Sub assurePath(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
    Set fso = Nothing
    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
        Set xl = Nothing
    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