Microsoft Access VBA Code Snippets

From database24
Jump to navigation Jump to search

ActiveX Data Objects (ADO)

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

Setter and Getter

In order to store and retrieve settings from the user's registry, it is wise to implement Setters and Getters. The general code for a variable named "Id" of the variable type "Long" looks like this: 

10 Public Sub setId(lngId As Long)
11     SaveSetting getProjectName, "RunTime", "Id", CStr(lngId)
12 End Sub

20 Public Function getId() As Long
21     Dim lngResult As Long
22     
23     lngResult = CLng(GetSetting(getProjectName, "RunTime", "Id", 0))
24     
25     getId = lngResult
26 End Function

A few remarks on this code:

  • Lines 11 and 23: "RunTime" just indicates that the variable will change frequently while working with the database. You may want to use different "categories" for your settings such as "RunTime", "Import", "User" and so on in order to reflect either the scope or the frequency of the settings. If you are using distinct namespaces like this, you should consider putting the namespace into the names of the functions, so that on the one hand it is possible to tell from the names which settings are meant and on the other hand you could reuse a term like Id in both namespaces; example: getId vs getImportId
  • Lines 11 and 23: The setting's name ("Id") should be the same that the functions have ("setId", "getId").
  • Lines 10, 20ff: The variable type should always be converted explicitly, although VBA is able to cast implicit conversions (like strResult = datNow).

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

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

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

setTableDescription / getTableDescription

The property "Description" is not initially present in a table definition. Therefore it has to be created and appended to the property collection of the table definition on first usage. 

Sub setTableDescription(strTable As String, strDescription As String)
    Dim dbs As Database
    Dim tdf As TableDef
    Dim prp As Property
    
    Set dbs = CurrentDb
    Set tdf = dbs.TableDefs(strTable)
    
    On Error GoTo handleSetTableDescriptionError
    tdf.Properties("Description").Value = strDescription
    On Error GoTo 0
    Exit Sub
    
handleSetTableDescriptionError:
    If Err.Number = 3270 Then
        Set prp = tdf.CreateProperty("Description", dbText, strDescription)
        tdf.Properties.Append prp
        Resume Next
    Else
        MsgBox Err.Number & ": " & Err.Description
    End If
End Sub

Public Function getTableDescription(strTable As String) As String
    Dim strResult As String

    On Error Resume Next
    strResult = CurrentDb.TableDefs(strTable).Properties("Description").Value
    On Error GoTo 0
    
    getTableDescription = strResult
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

linkTable

Public Sub linkTable( _
    strTable As String, _
    strFilePath As String, _
    Optional strTableSource As String = "" _
    )
    Dim dbs As Database
    Dim tdf As TableDef
    
    If strTableSource = "" Then
        strTableSource = strTable
    End If
    
    setStatus "Linking table '" & strTable & "' to " & strFilePath & " (" & strTableSource & ") ..."
    Set dbs = CurrentDb
    If existsTable(strTable) Then
        DoCmd.DeleteObject acTable, strTable
    End If
    Set tdf = dbs.CreateTableDef(strTable)
    With tdf
        .Connect = ";DATABASE=" & strFilePath
        .SourceTableName = strTableSource
    End With
    dbs.TableDefs.Append tdf
    setTableDescription strTable, strFilePath
    setStatus
End Sub

updateForms

This method is used to reflect global changes in all open forms. The error handling is necessary in case a corresponding method should be missing. 

Public Sub updateForms()
    Dim aob As AccessObject
    
    For Each aob In CurrentProject.AllForms
        With aob
            If .IsLoaded Then
                On Error Resume Next
                Forms.Item(.Name).updateForm
                On Error GoTo 0
            End If
        End With
    Next
End Sub

In order to use this, two prerequisites must be met, which will be illustrated using a combo box which display a customer (cmbCustomer) and should reflect changes of a globally stored customer id (using setCustomerId / getCustomerId, for example):

  • the changing procedure must call updateForms after the value has been changed
Private Sub cmbCustomer_AfterUpdate()
    setCustomerId cmbCustomer.Value
    updateForms
End Sub
  • every form, which uses the customer id, must have a public method "updateForm" which is responsible for reflecting the change in the form (or report).
Public Sub updateForm()
    cmbCustomer.Value = getCustomerId
End Sub

removeDeprecatedObjects

Public Sub removeDeprecatedObjects(Optional blnExecute As Boolean = False)
    'All objects
    removeObjects "^[z]?_.*", blnExecute
    removeObjects "[0-9]{6}", blnExecute
    removeObjects "_alt[0-9]*$", blnExecute
    
    'Specific tables
    removeTables "(einfüge|import)fehler", blnExecute
    removeTables "^(temp|test)", blnExecute
    
    'Specific queries
    removeQueries "^abfrage", blnExecute
    
    'Specific forms
    
    'Specific reports
    
    If Not blnExecute Then
        Debug.Print
        Debug.Print _
            "If you would like to delete the above mentioned objects," & vbCrLf & _
            "please run 'removeDeprecatedObjects true'."
    End If
End Sub

removeObjects

Public Sub removeObjects(strPattern As String, Optional blnExecute As Boolean = False)
    removeTables strPattern, blnExecute
    removeQueries strPattern, blnExecute
    removeForms strPattern, blnExecute
    removeReports strPattern, blnExecute
End Sub

removeTables

Public Sub removeTables(strPattern As String, Optional blnExecute As Boolean = False)
    Dim tdf As TableDef
    Dim strTable As String
 
    For Each tdf In CurrentDb.TableDefs
        strTable = tdf.Name
        If matches(strTable, strPattern) Then
            setStatus "Removing table '" & strTable & "' ..."
            Debug.Print "Removing table '" & strTable & "' ..."
            If blnExecute Then
                DoCmd.DeleteObject acTable, strTable
            End If
        End If
    Next
    setStatus
End Sub

removeQueries

Public Sub removeQueries(strPattern As String, Optional blnExecute As Boolean = False)
    Dim qdf As QueryDef
    Dim strQuery As String
 
    For Each qdf In CurrentDb.QueryDefs
        strQuery = qdf.Name
        If matches(strQuery, strPattern) Then
            setStatus "Removing query '" & strQuery & "' ..."
            Debug.Print "Removing query '" & strQuery & "' ..."
            If blnExecute Then
                DoCmd.DeleteObject acQuery, strQuery
            End If
        End If
    Next
    setStatus
End Sub

removeForms

Public Sub removeForms(strPattern As String, Optional blnExecute As Boolean = False)
    Dim afs As AllForms
    Dim aob As AccessObject
    Dim strForm As String
 
    Set afs = CurrentProject.AllForms
    For Each aob In afs
        strForm = aob.Name
        If matches(strForm, strPattern) Then
            setStatus "Removing Form '" & strForm & "' ..."
            Debug.Print "Removing Form '" & strForm & "' ..."
            If blnExecute Then
                DoCmd.DeleteObject acForm, strForm
            End If
        End If
    Next
    setStatus
End Sub

removeReports

Public Sub removeReports(strPattern As String, Optional blnExecute As Boolean = False)
    Dim arp As AllReports
    Dim aob As AccessObject
    Dim strReport As String
 
    Set arp = CurrentProject.AllReports
    For Each aob In arp
        strReport = aob.Name
        If matches(strReport, strPattern) Then
            setStatus "Removing Report '" & strReport & "' ..."
            Debug.Print "Removing Report '" & strReport & "' ..."
            If blnExecute Then
                DoCmd.DeleteObject acReport, strReport
            End If
        End If
    Next
    setStatus
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
    Dim strErr As String
    Dim strTable As String
    Dim strAffected As String
    
    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 handleExecuteError
        If isDebug Then
            .Execute strSql, dbFailOnError
        Else
            .Execute strSql
        End If
        On Error GoTo 0
        'DoCmd.SetWarnings True
        DoEvents
        
        strAffected = "Records    "
        Select Case .RecordsAffected
        Case 1
            'Last inserted id
            lngResult = .OpenRecordset("SELECT @@IDENTITY")(0)
            If lngResult = 0 Then
                lngResult = 1
            Else
                strAffected = "Last Id    "
            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 strAffected & ": " & Format(lngResult, "#,##0")
        Debug.Print "----------------------------------------"
        Debug.Print
    End If

    executeSql = lngResult
    Exit Function
    
handleExecuteError:
    'On Error GoTo handleExecuteSqlErrorFinal
    'DoCmd.RunSQL strSql
    'On Error GoTo 0
    'resume next
    'handleExecuteSqlErrorFinal:

    Select Case Err.Number
    
    Case 3010:
        'Table already exists
        strErr = Err.Description
        strTable = Mid( _
            Err.Description, _
            InStr(1, strErr, "'", vbTextCompare) + 1, _
            InStrRev(strErr, "'", -1, vbTextCompare) - _
                InStr(1, strErr, "'", vbTextCompare) - 1 _
            )
        DoCmd.Close acTable, strTable, acSaveNo
        DoCmd.DeleteObject acTable, strTable
        Resume
    
    Case 2008:
        'Table is open
        DoCmd.Close acTable, strTable, acSaveNo
        Resume
    
    Case Else
        strErr = Err.Number & " : " & Err.Description
        Debug.Print "########################################"
        Debug.Print "# ERR " & Err.Number & " : " & Err.Description
        Debug.Print "# ABORT"
        Debug.Print "########################################"
        Debug.Print
    
    End Select
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
    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
        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
        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
            .Activate
            '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
End Sub

modString

getAlNumString

Public Function getAlNumString(strSource As String) As String
    Dim strResult As String
 
    Dim intIndex As Integer
    Dim strCharacter As String
 
    strResult = ""
    For intIndex = 1 To Len(strSource)
        strCharacter = Mid(strSource, intIndex, 1)
        Select Case Asc(strCharacter)
 
        ''A - Z, a - z
        Case 65 To 90, 97 To 122
            strResult = strResult & strCharacter
        
        '0 - 9
        Case 48 To 57
            strResult = strResult & strCharacter
        
        Case Else
            'nothing
        
        End Select
    Next
 
    getAlNumString = strResult
End Function

getAlNumPunctString

Public Function getAlNumPunctString(strSource As String) As String
    Dim strResult As String
 
    Dim intIndex As Integer
    Dim strCharacter As String
 
    strResult = ""
    For intIndex = 1 To Len(strSource)
        strCharacter = Mid(strSource, intIndex, 1)
        Select Case Asc(strCharacter)
 
        'A - Z, a - z
        Case 65 To 90, 97 To 122
            strResult = strResult & strCharacter
        
        '0 - 9
        Case 48 To 57
            strResult = strResult & strCharacter
        
        '<space>, <comma>, <hyphen>, <dot>, <slash>
        Case 20, 44 To 47
            strResult = strResult & strCharacter
        
        Case Else
            'nothing
        
        End Select
    Next
 
    getAlNumPunctString = strResult
End Function

getPrintableString

Public Function getPrintableString(strSource As String) As String
    Dim strResult As String
 
    Dim intIndex As Integer
    Dim strCharacter As String
 
    strResult = ""
    For intIndex = 1 To Len(strSource)
        strCharacter = Mid(strSource, intIndex, 1)
        Select Case Asc(strCharacter)
 
        'ASCII printable characters
        Case 20 To 126
            strResult = strResult & strCharacter
 
        Case Else
            'nothing
        
        End Select
    Next
 
    getPrintableString = strResult
End Function

matches

Public Function matches(strString As String, strRegEx As String) As Boolean
    Dim blnResult As Boolean
    
    Dim rgx As RegExp
    
    Set rgx = New RegExp
    With rgx
        .Pattern = strRegEx
        blnResult = .Test(strString)
    End With
    
    matches = blnResult
End Function
Retrieved from "http://wiki.database24.net/index.php?title=Microsoft_Access_VBA_Code_Snippets&oldid=73"