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

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

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