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

</syntaxhighlight lang="vb">

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

</syntaxhighlight>