Difference between revisions of "Microsoft Access VBA Code Snippets"

From database24
Jump to navigation Jump to search
 
(5 intermediate revisions by the same user not shown)
Line 1: Line 1:
−
== ActiveX Data Objects (ADO) ==
+
[[Category:Microsoft Access]]
 +
[[Category:VBA]]
 +
== General ==
 +
 
 +
=== ActiveX Data Objects (ADO) ===
 
Retrieving and processing a recordset works like this
 
Retrieving and processing a recordset works like this
  
 
<syntaxhighlight lang="vb">
 
<syntaxhighlight lang="vb">
−
     Dim cn As ADODB.Connection
+
     Dim cnn As ADODB.Connection
−
     Dim rs As ADODB.Recordset
+
     Dim rst As ADODB.Recordset
 
      
 
      
−
     Set cn = CurrentProject.Connection
+
     Set cnn = CurrentProject.Connection
−
     Set rs = New ADODB.Recordset
+
     Set rst = New ADODB.Recordset
−
     With rs
+
     With rst
 
         .Open _
 
         .Open _
 
             Source:="SELECT * FROM tblTable", _
 
             Source:="SELECT * FROM tblTable", _
−
             ActiveConnection:=cn
+
             ActiveConnection:=cnn
 
         .MoveFirst
 
         .MoveFirst
 
         Do While Not .EOF
 
         Do While Not .EOF
Line 21: Line 25:
 
</syntaxhighlight>
 
</syntaxhighlight>
  
−
== Setter and Getter ==
+
=== 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:
 
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:
  
Line 49: Line 53:
  
 
== Modules ==
 
== Modules ==
−
* [[Microsoft Access 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.
+
* [[Microsoft Access modAccess|modAccess]]
−
 
+
* [[Microsoft Access modSetting|modSetting]]
−
== modSetting ==
+
* [[Microsoft Access modUi|modUi]]
−
 
+
* [[Microsoft Access modFunction|modFunction]]
−
=== debugPrintUserRunTimeSettings ===
+
* [[Microsoft Access modSql|modSql]]
−
<syntaxhighlight lang="vb">
+
* [[Microsoft Access modFso|modFso]]
−
Sub debugPrintUserRunTimeSettings()
+
* [[Microsoft Access modWsh|modWsh]]
−
    Dim arrSetting() As String
+
* [[Microsoft Access modExcel|modExcel]]
−
    Dim intIndex As Integer
+
* [[Microsoft Access modString|modString]]
−
   
 
−
    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
 
−
</syntaxhighlight>
 
−
 
 
−
=== deleteUserSettings ===
 
−
<syntaxhighlight lang="vb">
 
−
Sub deleteUserSettings()
 
−
    Debug.Print
 
−
    Debug.Print "User Settings"
 
−
    Debug.Print "-------------"
 
−
    On Error Resume Next
 
−
    DeleteSetting getProjectName
 
−
    Debug.Print "All user settings deleted."
 
−
End Sub
 
−
</syntaxhighlight>
 
−
 
 
−
== modUi ==
 
−
 
 
−
=== setStatus ===
 
−
<syntaxhighlight lang="vb">
 
−
Public Sub setStatus(Optional strMessage As String = "Bereit")
 
−
    strMessage = _
 
−
        getUserName & " - " & _
 
−
        strMessage
 
−
    SysCmd acSysCmdSetStatus, strMessage
 
−
End Sub
 
−
</syntaxhighlight>
 
−
 
 
−
== 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):
 
−
<syntaxhighlight lang="vb">
 
−
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
 
−
</syntaxhighlight>
 
−
 
 
−
The "round3 Solution" is limited by the amount of decimal places of the currency data type (4 decimal places):
 
−
<syntaxhighlight lang="vb">
 
−
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
 
−
</syntaxhighlight>
 
−
 
 
−
=== 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.
 
−
 
 
−
<syntaxhighlight lang="vb">
 
−
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
 
−
</syntaxhighlight>
 
−
 
 
−
== modSql ==
 
−
 
 
−
=== Constants ===
 
−
<syntaxhighlight lang="vb">
 
−
Public Const strFormatSqlDate As String = "yyyy\-mm\-dd"
 
−
Public Const strFormatSqlDateCriterion As String = "\#yyyy\-mm\-dd\#"
 
−
</syntaxhighlight>
 
−
 
 
−
=== executeSql ===
 
−
<syntaxhighlight lang="vb">
 
−
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
 
−
</syntaxhighlight>
 
−
 
 
−
=== showSqlResult ===
 
−
<syntaxhighlight lang="vb">
 
−
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
 
−
</syntaxhighlight>
 
−
 
 
−
=== getSqlAmount ===
 
−
<syntaxhighlight lang="vb">
 
−
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
 
−
</syntaxhighlight>
 
−
 
 
−
=== getSqlDate ===
 
−
<syntaxhighlight lang="vb">
 
−
Public Function getSqlDate(dat As Date) As String
 
−
    Dim strResult As String
 
−
   
 
−
    strResult = Format(dat, strFormatSqlDate)
 
−
   
 
−
    getSqlDate = strResult
 
−
End Function
 
−
</syntaxhighlight>
 
−
 
 
−
=== getSqlDateCriterion ===
 
−
<syntaxhighlight lang="vb">
 
−
Public Function getSqlDateCriterion(dat As Date) As String
 
−
    Dim strResult As String
 
−
   
 
−
    strResult = Format(dat, strFormatSqlDateCriterion)
 
−
   
 
−
    getSqlDateCriterion = strResult
 
−
End Function
 
−
</syntaxhighlight>
 
−
 
 
−
== modFso ==
 
−
 
 
−
=== assertPath ===
 
−
<syntaxhighlight lang="vb">
 
−
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
 
−
</syntaxhighlight>
 
−
 
 
−
== modWsh ==
 
−
Windows Scripting Host Object based methods
 
−
 
 
−
=== getUserName ===
 
−
<syntaxhighlight lang="vb">
 
−
Function getUserName() As String
 
−
    Dim strResult As String
 
−
   
 
−
    Dim wshNet As WshNetwork
 
−
   
 
−
    Set wshNet = New WshNetwork
 
−
    strResult = wshNet.UserName
 
−
   
 
−
    getUserName = strResult
 
−
End Function
 
−
</syntaxhighlight>
 
−
 
 
−
=== getComputerName ===
 
−
<syntaxhighlight lang="vb">
 
−
Function getComputerName() As String
 
−
    Dim strResult As String
 
−
   
 
−
    Dim wshNet As WshNetwork
 
−
   
 
−
    Set wshNet = New WshNetwork
 
−
    strResult = wshNet.ComputerName
 
−
   
 
−
    getComputerName = strResult
 
−
End Function
 
−
</syntaxhighlight>
 
−
 
 
−
=== getUserSuffix ===
 
−
<syntaxhighlight lang="vb">
 
−
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
 
−
</syntaxhighlight>
 
−
 
 
−
=== getUserTempTable ===
 
−
<syntaxhighlight lang="vb">
 
−
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
 
−
</syntaxhighlight>
 
−
 
 
−
== modExcel ==
 
−
 
 
−
=== Variables ===
 
−
<syntaxhighlight lang="vb">
 
−
Private xl As Excel.Application
 
−
Private blnCreated As Boolean
 
−
</syntaxhighlight>
 
−
 
 
−
=== getExcel ===
 
−
<syntaxhighlight lang="vb">
 
−
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
 
−
</syntaxhighlight>
 
−
 
 
−
=== quitExcel ===
 
−
<syntaxhighlight lang="vb">
 
−
Sub quitExcel()
 
−
    With xl
 
−
        If blnCreated Then
 
−
            .Quit
 
−
            blnCreated = False
 
−
        End If
 
−
    End With
 
−
End Sub
 
−
</syntaxhighlight>
 
−
 
 
−
=== openExcelWorkbook ===
 
−
<syntaxhighlight lang="vb">
 
−
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
 
−
</syntaxhighlight>
 
−
 
 
−
=== closeExcelWorkbook ===
 
−
<syntaxhighlight lang="vb">
 
−
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
 
−
</syntaxhighlight>
 
−
 
 
−
=== applyCorporateStyle ===
 
−
<syntaxhighlight lang="vb">
 
−
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
 
−
</syntaxhighlight>
 
−
 
 
−
=== subTotalColumn ===
 
−
<syntaxhighlight lang="vb">
 
−
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
 
−
</syntaxhighlight>
 
−
 
 
−
=== sumColumn ===
 
−
<syntaxhighlight lang="vb">
 
−
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
 
−
</syntaxhighlight>
 
−
 
 
−
=== formatColumnNumber ===
 
−
<syntaxhighlight lang="vb">
 
−
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
 
−
</syntaxhighlight>
 
−
 
 
−
=== formatColumnBackground ===
 
−
<syntaxhighlight lang="vb">
 
−
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
 
−
</syntaxhighlight>
 
−
 
 
−
== modString ==
 
−
 
 
−
=== getAlNumString ===
 
−
<syntaxhighlight lang="vb">
 
−
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
 
−
</syntaxhighlight>
 
−
 
 
−
=== getAlNumPunctString ===
 
−
<syntaxhighlight lang="vb">
 
−
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
 
−
</syntaxhighlight>
 
−
 
 
−
=== getPrintableString ===
 
−
<syntaxhighlight lang="vb">
 
−
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
 
−
</syntaxhighlight>
 
−
 
 
−
=== matches ===
 
−
<syntaxhighlight lang="vb">
 
−
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
 
−
</syntaxhighlight>
 

Latest revision as of 00:01, 10 August 2010

General

ActiveX Data Objects (ADO)

Retrieving and processing a recordset works like this 

    Dim cnn As ADODB.Connection
    Dim rst As ADODB.Recordset
    
    Set cnn = CurrentProject.Connection
    Set rst = New ADODB.Recordset
    With rst
        .Open _
            Source:="SELECT * FROM tblTable", _
            ActiveConnection:=cnn
        .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

Retrieved from "http://wiki.database24.net/index.php?title=Microsoft_Access_VBA_Code_Snippets&oldid=289"