Difference between revisions of "Microsoft Access VBA Code Snippets"

From database24
Jump to navigation Jump to search
 
(70 intermediate revisions by 2 users not shown)
Line 1: Line 1:
−
== ActiveX Data Objects ==
+
[[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
−
        'Record based instructions
+
            'Record based instructions
−
        .MoveNext
+
            .MoveNext
−
    Loop
+
        Loop
−
    .Close
+
        .Close
−
End With
+
     End With
−
 
−
Set rs = Nothing
 
−
Set cn = Nothing
 
−
</syntaxhighlight>
 
−
 
 
−
 
 
−
== 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 ===
 
−
<syntaxhighlight lang="vb">
 
−
Function getApplicationTitle() As String
 
−
    Dim strResult As String
 
−
   
 
−
    strResult = CurrentDb.Properties("AppTitle").Value
 
−
   
 
−
    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
 
−
   
 
−
    getDbAppTitle = strResult
 
−
End Function
 
−
</syntaxhighlight>
 
−
 
 
−
=== setDebug ===
 
−
<syntaxhighlight lang="vb">
 
−
Sub setDebug(blnDebug As Boolean)
 
−
    saveSetting getProjectName, "RunTime", "Debug", CStr(blnDebug)
 
−
End Sub
 
−
</syntaxhighlight>
 
−
 
 
−
=== isDebug ===
 
−
<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>
 
−
 
 
−
=== 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>
 
−
 
 
−
 
 
−
== 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
 
−
   
 
−
    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 handleExecuteSqlError
 
−
        If isDebug Then
 
−
            .Execute strSql, dbFailOnError
 
−
        Else
 
−
            .Execute strSql
 
−
        End If
 
−
        'On Error GoTo 0
 
−
        'DoCmd.SetWarnings True
 
−
        DoEvents
 
−
       
 
−
        Select Case .RecordsAffected
 
−
        Case 1
 
−
            'Last inserted id
 
−
            lngResult = .OpenRecordset("SELECT @@IDENTITY")(0)
 
−
        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 "Records    : " & Format(lngResult, "#,##0")
 
−
        Debug.Print "----------------------------------------"
 
−
        Debug.Print
 
−
    End If
 
−
 
−
    executeSql = lngResult
 
−
    'Exit Function
 
−
   
 
−
'handleExecuteSqlError:
 
−
'    On Error GoTo handleExecuteSqlErrorFinal
 
−
'    DoCmd.RunSQL strSql
 
−
'    On Error GoTo 0
 
−
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
 
−
    Set qdf = Nothing
 
−
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>
 
</syntaxhighlight>
  
 +
=== 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:
  
−
== modFso ==
+
<syntaxhighlight lang="vb" line start="10" highlight="2">
−
 
+
Public Sub setId(lngId As Long)
−
=== assurePath ===
+
    SaveSetting getProjectName, "RunTime", "Id", CStr(lngId)
−
<syntaxhighlight lang="vb">
+
End Sub
−
Sub assurePath(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
 
−
    Set fso = Nothing
 
−
    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>
 
</syntaxhighlight>
  
−
 
+
<syntaxhighlight lang="vb" line start="20" highlight="4">
−
== modWsh ==
+
Public Function getId() As Long
−
Windows Scripting Host Object based methods
+
    Dim lngResult As Long
−
 
+
   
−
=== getUserName ===
+
    lngResult = CLng(GetSetting(getProjectName, "RunTime", "Id", 0))
−
<syntaxhighlight lang="vb">
+
   
−
Function getUserName() As String
+
    getId = lngResult
−
    Dim strResult As String
+
End Function
−
   
 
−
    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>
 
</syntaxhighlight>
  
−
== modExcel ==
+
A few remarks on this code:
  
−
=== Variables ===
+
* 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''
−
<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 ===
+
* Lines 11 and 23: The setting's name ("''Id''") should be the same that the functions have ("set''Id''", "get''Id''").
−
<syntaxhighlight lang="vb">
 
−
Sub quitExcel()
 
−
    With xl
 
−
        If blnCreated Then
 
−
            .Quit
 
−
        End If
 
−
        Set xl = Nothing
 
−
    End With
 
−
End Sub
 
−
</syntaxhighlight>
 
  
−
=== openExcelWorkbook ===
+
* Lines 10, 20ff: The variable type should always be converted explicitly, although VBA is able to cast implicit conversions (like strResult = datNow).
−
<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 ===
+
== Modules ==
−
</syntaxhighlight lang="vb">
+
* [[Microsoft Access modAccess|modAccess]]
−
Public Sub closeExcelWorkbook(strWorkbook As String, Optional blnQuit As Boolean = False)
+
* [[Microsoft Access modSetting|modSetting]]
−
    With xl
+
* [[Microsoft Access modUi|modUi]]
−
        .Workbooks(strWorkbook).Close
+
* [[Microsoft Access modFunction|modFunction]]
−
        If blnQuit Then
+
* [[Microsoft Access modSql|modSql]]
−
            quitExcel
+
* [[Microsoft Access modFso|modFso]]
−
        End If
+
* [[Microsoft Access modWsh|modWsh]]
−
    End With
+
* [[Microsoft Access modExcel|modExcel]]
−
End Sub
+
* [[Microsoft Access modString|modString]]
−
</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"