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
    
    Set rs = Nothing
    Set cn = Nothing

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

    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)
                If lngResult = 0 Then
                    lngResult = 1
                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 "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

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

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
            '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
    
    Set rng = Nothing
    Set wks = Nothing
    Set wbk = Nothing
    Set xls = Nothing
    Set fso = Nothing
End Sub