Microsoft Access VBA Code Snippets

From database24
Revision as of 13:36, 1 July 2010 by Dec (talk | contribs) (→‎Modules)
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).

Modules

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

round

Microsoft Access' Round() function is different from the one implemented in Microsoft Excel. The behavious can be imitated using a user defined function.

The "round2 Solution" is limited by the size of the long data type (roughly 2 billion): 

Public Function round2(ByVal dblValue As Double, intDecimal As Integer) As Double
    Dim dblResult As Double
    
    Dim lngFactor As Long
    
    lngFactor = 10 ^ (intDecimal)
    dblResult = CLng(dblValue * lngFactor) / lngFactor
    
    round2 = dblResult
End Function

The "round3 Solution" is limited by the amount of decimal places of the currency data type (4 decimal places): 

Public Function round3(ByVal dblValue As Double, intDecimal As Integer) As Double
    Dim dblResult As Double
    
    Dim lngFactor As Long
    
    lngFactor = 10 ^ (intDecimal)
    dblResult = CCur(dblValue / lngFactor) * lngFactor
    
    round3 = dblResult
End Function

lookupRecordset

The domain aggregate functions suffer from performance problems. This function performs a simple lookup in a recordset. The performance of this function compared to the built-in function still has to be proven. 

Public Function lookupRecordset( _
    ByVal strFieldName As String, _
    ByVal strSource As String, _
    Optional ByVal strCriteria As String = vbNullString _
    ) As Variant
    Dim varResult as Variant
    
    Dim strSql As String
    Dim rst As Recordset
    
    strSql = _
        "SELECT " & strFieldName & "    " & vbCrLf & _
        "  FROM " & strSource & "       "
    If strCriteria > vbNullString Then
        strSql = strSql & vbCrLf & _
            " WHERE " & strCriteria
    End If
    Set rst = CurrentDb.OpenRecordset(strSql, dbOpenSnapshot)
    With rst
        If .EOF Then
                varResult = Null
            Else
                varResult = .Fields(0)
        End If
        .Close
    End With
    
    lookupRecordset = varResult
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
        If isDebug Then
            Stop
        End If
    
    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

getUserSuffix

Public Function getUserSuffix() As String
    Dim strResult As String
    
    strResult = getUserName
    strResult = Replace(strResult, ".", "")
    strResult = Replace(strResult, ",", "")
    strResult = Replace(strResult, "-", "")
    strResult = Replace(strResult, " ", "")
    strResult = "_" & strResult
    
    getUserSuffix = strResult
End Function

getUserTempTable

Public Function getUserTempTable(strSource As String) As String
    Dim strResult As String
    
    Const strTablePrefix = "_tbl"
    
    strResult = strTablePrefix & Mid(strSource, 4) & getUserSuffix
    
    getUserTempTable = strResult
End Function

modExcel

Variables

Private xl As Excel.Application
Private blnCreated As Boolean

getExcel

Private Function getExcel(Optional blnVisible As Boolean = False) 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 = blnVisible
            blnCreated = True
        Else
            blnCreated = False
        End If
    End If
    
    Set getExcel = xl
End Function

quitExcel

Sub quitExcel()
    With xl
        If blnCreated Then
            .Quit
            blnCreated = False
        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 blnSave As Boolean = True, Optional blnQuit As Boolean = False)
    With xl
        With .Workbooks(strWorkbook)
            If blnSave Then
                .Save
            End If
            .Close SaveChanges:=False
        End With
        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
                .Activate

                'Remove gridlines and freeze pane
                .Cells(2, 1).Select
                With xls.ActiveWindow
                    .DisplayGridlines = False
                    .FreezePanes = True
                End With
            
                '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

            'Number formatting
            For Each rng In .Columns
                
                'First row values
                With rng.Cells(2, 1)
                    If IsDate(.Value) Then
                        rng.NumberFormat = strFormatDate
                    ElseIf IsNumeric(.Value) Then
                        rng.NumberFormat = strFormatCurrency
                    End If
                End With
            Next

        End With
    Next
    
    closeExcelWorkbook strWorkbook:=wbk.Name, blnSave:=True
End Sub

subTotalColumn

Public Sub subTotalColumn( _
    strFilePath As String, _
    strWorksheet As String, _
    ParamArray arrColumnName() _
    )
    Dim wbk As Workbook
    Dim wks As Worksheet
    Dim rng As Range
    
    Dim varColumnName As Variant
    Dim rngFormula As Range
    Dim rngSum As Range
    Dim intRow As Integer
 
    Set wbk = openExcelWorkbook(strFilePath)
    Set wks = wbk.Worksheets(strWorksheet)
    With wks
        
        intRow = .UsedRange.Rows.Count
        
        'Add lines for sub totals
        .Rows("1:1").Insert Shift:=xlDown
        .Rows("1:1").Insert Shift:=xlDown
        .Rows("1:1").Insert Shift:=xlDown
        
        intRow = intRow + 3
        
        For Each varColumnName In arrColumnName
        
            Set rngFormula = .Rows(4).Find( _
                What:=varColumnName).Offset(-2, 0)
            
            Set rngSum = .Range( _
                .Cells(5, rngFormula.column), _
                .Cells(intRow, rngFormula.column))
            
            Debug.Print
            Debug.Print "UsedRg : " & .UsedRange.Rows.Count
            Debug.Print "intRow : " & intRow
            Debug.Print "rngSum : " & rngSum.Address
            Debug.Print
            
            If IsNumeric(rngSum.Cells(1, 1)) Then
                rngFormula.Formula = _
                    "=SUBTOTAL(9," & rngSum.Address & ")"
            Else
                rngFormula.Formula = _
                    "=SUBTOTAL(3," & rngSum.Address & ")"
                rngFormula.NumberFormat = "0 ""Receipts"""
            End If
        Next
        
    End With
    
    rngFormula.EntireRow.Font.Bold = True
    
    closeExcelWorkbook strWorkbook:=wbk.Name, blnSave:=True
End Sub

sumColumn

Public Sub sumColumn( _
    strFilePath As String, _
    strWorksheet As String, _
    ParamArray arrColumn() _
    )
    Dim wbk As Workbook
    Dim wks As Worksheet
    Dim rng As Range
    
    Dim varIndex As Variant
    Dim rngSum As Range
    Dim intRow As Integer
 
    Set wbk = openExcelWorkbook(strFilePath)
    Set wks = wbk.Worksheets(strWorksheet)
    With wks
        intRow = .UsedRange.Rows.Count
        For Each varIndex In arrColumn
            Set rngSum = .Range( _
                .Cells(1, varIndex), _
                .Cells(intRow, varIndex))
            rngSum.Cells(intRow, 1).Offset(2, 0).Formula = "=SUM(" & rngSum.Address & ")"
        Next
    End With
    
    closeExcelWorkbook strWorkbook:=wbk.Name, blnSave:=True
End Sub

formatColumnNumber

Public Sub formatColumnNumber( _
    strFilePath As String, _
    strWorksheet As String, _
    strNumberFormat As String, _
    ParamArray arrColumn() _
    )
    Dim wbk As Workbook
    Dim wks As Worksheet
    Dim rng As Range
    
    Dim varIndex As Variant
 
    Set wbk = openExcelWorkbook(strFilePath)
    Set wks = wbk.Worksheets(strWorksheet)
    With wks
        For Each varIndex In arrColumn
            .Columns(varIndex).NumberFormat = strNumberFormat
        Next
    End With
    
    closeExcelWorkbook strWorkbook:=wbk.Name, blnSave:=True
End Sub

formatColumnBackground

Public Sub formatColumnBackground( _
    strFilePath As String, _
    strWorksheet As String, _
    lngColor As Long, _
    ParamArray arrColumn() _
    )
    Dim wbk As Workbook
    Dim wks As Worksheet
    Dim rng As Range
    
    Dim intRow As Integer
    Dim varIndex As Variant
 
    Set wbk = openExcelWorkbook(strFilePath)
    Set wks = wbk.Worksheets(strWorksheet)
    With wks
        intRow = .UsedRange.Rows.Count
        For Each varIndex In arrColumn
            .Range( _
                Cells(2, varIndex), _
                Cells(intRow, varIndex) _
            ).Interior.Color = lngColor
        Next
    End With
    
    closeExcelWorkbook strWorkbook:=wbk.Name, blnSave:=True
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=128"