Difference between revisions of "Microsoft Access VBA Code Snippets"

From database24
Jump to navigation Jump to search
 
(25 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 48: Line 52:
 
* Lines 10, 20ff: The variable type should always be converted explicitly, although VBA is able to cast implicit conversions (like strResult = datNow).
 
* Lines 10, 20ff: The variable type should always be converted explicitly, although VBA is able to cast implicit conversions (like strResult = datNow).
  
−
== modAccess ==
+
== Modules ==
−
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]]
−
=== getApplicationTitle ===
+
* [[Microsoft Access modUi|modUi]]
−
<syntaxhighlight lang="vb">
+
* [[Microsoft Access modFunction|modFunction]]
−
Function getApplicationTitle() As String
+
* [[Microsoft Access modSql|modSql]]
−
    Dim strResult As String
+
* [[Microsoft Access modFso|modFso]]
−
   
+
* [[Microsoft Access modWsh|modWsh]]
−
    strResult = CurrentDb.Properties("AppTitle").Value
+
* [[Microsoft Access modExcel|modExcel]]
−
   
+
* [[Microsoft Access modString|modString]]
−
    getApplicationTitle = strResult
 
−
End Function
 
−
</syntaxhighlight>
 
−
 
 
−
=== 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.
 
−
 
 
−
<syntaxhighlight lang="vb">
 
−
Function getProjectName() As String
 
−
    Dim strResult As String
 
−
   
 
−
    strResult = Application.VBE.ActiveVBProject.Name
 
−
   
 
−
    getProjectName = strResult
 
−
End Function
 
−
</syntaxhighlight>
 
−
 
 
−
=== setDebug / isDebug ===
 
−
<syntaxhighlight lang="vb">
 
−
Sub setDebug(blnDebug As Boolean)
 
−
    saveSetting getProjectName, "RunTime", "Debug", CStr(blnDebug)
 
−
End Sub
 
−
</syntaxhighlight>
 
−
 
 
−
<syntaxhighlight lang="vb">
 
−
Function isDebug() As Boolean
 
−
    Dim blnResult As Boolean
 
−
   
 
−
    blnResult = CBool(GetSetting(getProjectName, "RunTime", "Debug", 0))
 
−
   
 
−
    isDebug = blnResult
 
−
End Function
 
−
</syntaxhighlight>
 
−
 
 
−
=== existsTable ===
 
−
<syntaxhighlight lang="vb">
 
−
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
 
−
</syntaxhighlight>
 
−
 
 
−
=== existsQuery ===
 
−
<syntaxhighlight lang="vb">
 
−
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
 
−
</syntaxhighlight>
 
−
 
 
−
=== 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.
 
−
 
 
−
<syntaxhighlight lang="vb">
 
−
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
 
−
</syntaxhighlight>
 
−
 
 
−
<syntaxhighlight lang="vb">
 
−
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
 
−
</syntaxhighlight>
 
−
 
 
−
=== inList ===
 
−
<syntaxhighlight lang="vb">
 
−
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
 
−
</syntaxhighlight>
 
−
 
 
−
=== displayActiveUsers ===
 
−
The usage of the Windows Script Host Object in order to identify the user's workstation is optional.
 
−
 
 
−
<syntaxhighlight lang="vb">
 
−
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
 
−
</syntaxhighlight>
 
−
 
 
−
=== linkTable ===
 
−
<syntaxhighlight lang="vb">
 
−
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
 
−
</syntaxhighlight>
 
−
 
 
−
=== 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.
 
−
<syntaxhighlight lang="vb">
 
−
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
 
−
</syntaxhighlight>
 
−
 
 
−
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
 
−
<syntaxhighlight lang="vb">
 
−
Private Sub cmbCustomer_AfterUpdate()
 
−
    setCustomerId cmbCustomer.Value
 
−
    updateForms
 
−
End Sub
 
−
</syntaxhighlight>
 
−
 
 
−
* 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).
 
−
<syntaxhighlight lang="vb">
 
−
Public Sub updateForm()
 
−
    cmbCustomer.Value = getCustomerId
 
−
End Sub
 
−
</syntaxhighlight>
 
−
 
 
−
=== removeDeprecatedObjects ===
 
−
<syntaxhighlight lang="vb">
 
−
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
 
−
</syntaxhighlight>
 
−
 
 
−
=== removeObjects ===
 
−
<syntaxhighlight lang="vb">
 
−
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
 
−
</syntaxhighlight>
 
−
 
 
−
=== removeTables ===
 
−
<syntaxhighlight lang="vb">
 
−
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
 
−
</syntaxhighlight>
 
−
 
 
−
=== removeQueries ===
 
−
<syntaxhighlight lang="vb">
 
−
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
 
−
</syntaxhighlight>
 
−
 
 
−
=== removeForms ===
 
−
<syntaxhighlight lang="vb">
 
−
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
 
−
</syntaxhighlight>
 
−
 
 
−
=== removeReports ===
 
−
<syntaxhighlight lang="vb">
 
−
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
 
−
</syntaxhighlight>
 
−
 
 
−
== modSetting ==
 
−
 
 
−
=== debugPrintUserRunTimeSettings ===
 
−
<syntaxhighlight lang="vb">
 
−
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
 
−
</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 ==
 
−
 
 
−
=== round2 ===
 
−
Microsoft Access' Round() function is different from the one implemented in Microsoft Excel. The behavious can be imitated using a user defined function.
 
−
 
 
−
<syntaxhighlight lang="vb">
 
−
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
 
−
</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
 
−
   
 
−
    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>
 
−
 
 
−
== modExcel ==
 
−
 
 
−
=== Variables ===
 
−
<syntaxhighlight lang="vb">
 
−
    Private xl As Excel.Application
 
−
    Private blnCreated As Boolean
 
−
</syntaxhighlight>
 
−
 
 
−
=== getExcel ===
 
−
<syntaxhighlight lang="vb">
 
−
    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
 
−
</syntaxhighlight>
 
−
 
 
−
=== quitExcel ===
 
−
<syntaxhighlight lang="vb">
 
−
    Sub quitExcel()
 
−
        With xl
 
−
            If blnCreated Then
 
−
                .Quit
 
−
            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 blnQuit As Boolean = False)
 
−
        With xl
 
−
            .Workbooks(strWorkbook).Close
 
−
            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
 
−
            .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
 
−
</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"