Difference between revisions of "Microsoft Access VBA Code Snippets"

From database24
Jump to navigation Jump to search
 
(74 intermediate revisions by 2 users not shown)
Line 1: Line 1:
−
== modAccess ==
+
[[Category:Microsoft Access]]
−
modAccess consists basically of methods, which are specific to Microsoft Access like methods for retrieving information about properties, checking Access objects for their existence.
+
[[Category:VBA]]
 +
== General ==
  
−
=== getApplicationTitle ===
+
=== ActiveX Data Objects (ADO) ===
−
Function getApplicationTitle() As String
+
Retrieving and processing a recordset works like this
−
    Dim strResult As String
 
−
   
 
−
    strResult = CurrentDb.Properties("AppTitle").Value
 
−
   
 
−
    getApplicationTitle = strResult
 
−
End Function
 
  
−
=== getProjectName ===
+
<syntaxhighlight lang="vb">
−
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.
+
    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
 +
</syntaxhighlight>
  
−
Function getProjectName() As String
+
=== Setter and Getter ===
−
    Dim strResult As String
+
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:
−
   
 
−
    strResult = Application.VBE.ActiveVBProject.Name
 
−
   
 
−
    getDbAppTitle = strResult
 
−
End Function
 
  
−
=== setDebug ===
+
<syntaxhighlight lang="vb" line start="10" highlight="2">
−
Sub setDebug(blnDebug As Boolean)
+
Public Sub setId(lngId As Long)
−
    saveSetting getProjectName, "RunTime", "Debug", CStr(blnDebug)
+
    SaveSetting getProjectName, "RunTime", "Id", CStr(lngId)
−
End Sub
+
End Sub
 +
</syntaxhighlight>
  
−
=== isDebug ===
+
<syntaxhighlight lang="vb" line start="20" highlight="4">
−
Function isDebug() As Boolean
+
Public Function getId() As Long
−
    Dim blnResult As Boolean
+
    Dim lngResult As Long
−
   
+
   
−
    blnResult = CBool(GetSetting(getProjectName, "RunTime", "Debug", 0))
+
    lngResult = CLng(GetSetting(getProjectName, "RunTime", "Id", 0))
−
   
+
   
−
    isDebug = blnResult
+
    getId = lngResult
−
End Function
+
End Function
 +
</syntaxhighlight>
  
−
=== existsTable ===
+
A few remarks on this code:
−
Function existsTable(strTable As String) As Boolean
 
−
    Dim blnResult As Boolean
 
−
    Dim tdf As TableDef
 
−
   
 
−
    blnResult = False
 
−
    For Each tdf In CurrentDb.TableDefs
 
−
        If tdf.Name = strTable Then
 
−
            blnResult = True
 
−
            Exit For
 
−
        End If
 
−
    Next
 
−
   
 
−
    existsTable = blnResult
 
−
End Function
 
  
−
=== existsQuery ===
+
* 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''
−
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
 
  
−
=== inList ===
+
* Lines 11 and 23: The setting's name ("''Id''") should be the same that the functions have ("set''Id''", "get''Id''").
−
Public Function inList(cmb As ComboBox, var As Variant) As Boolean
 
−
    Dim blnResult As Boolean
 
−
    Dim intIndex As Integer
 
−
   
 
−
    blnResult = False
 
−
    With cmb
 
−
        For intIndex = Abs(.ColumnHeads) To .ListCount - 1
 
−
            If CLng(.ItemData(intIndex)) = CLng(Nz(var)) Then
 
−
                blnResult = True
 
−
                Exit For
 
−
            End If
 
−
        Next
 
−
    End With
 
−
   
 
−
    inList = blnResult
 
−
End Function
 
  
−
=== displayActiveUsers ===
+
* Lines 10, 20ff: The variable type should always be converted explicitly, although VBA is able to cast implicit conversions (like strResult = datNow).
−
The usage of the Windows Script Host Object in order to identify the user's workstation is optional.
 
  
−
Sub displayActiveUsers()
+
== Modules ==
−
    Dim strUsers As String
+
* [[Microsoft Access modAccess|modAccess]]
−
    Dim cn As New ADODB.Connection
+
* [[Microsoft Access modSetting|modSetting]]
−
    Dim rs As New ADODB.Recordset
+
* [[Microsoft Access modUi|modUi]]
−
    Dim wshNet As WshNetwork
+
* [[Microsoft Access modFunction|modFunction]]
−
+
* [[Microsoft Access modSql|modSql]]
−
    strUsers = "Computer Name"
+
* [[Microsoft Access modFso|modFso]]
−
    Set cn = CurrentProject.Connection
+
* [[Microsoft Access modWsh|modWsh]]
−
    Set rs = cn.OpenSchema( _
+
* [[Microsoft Access modExcel|modExcel]]
−
        Schema:=adSchemaProviderSpecific, _
+
* [[Microsoft Access modString|modString]]
−
        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
 
−
 
 
−
 
 
−
== modSetting ==
 
−
 
 
−
=== debugPrintUserRunTimeSettings ===
 
−
Sub debugPrintUserRunTimeSettings()
 
−
    Dim arrSetting() As String
 
−
    Dim intIndex As Integer
 
−
   
 
−
    Debug.Print
 
−
    Debug.Print "User RunTime Settings"
 
−
    Debug.Print "---------------------"
 
−
    On Error GoTo handleGetAllSettingsError
 
−
    arrSetting = GetAllSettings(getProjectName, "RunTime")
 
−
    On Error GoTo 0
 
−
    For intIndex = LBound(arrSetting) To UBound(arrSetting)
 
−
        Debug.Print arrSetting(intIndex, 0) & " : " & arrSetting(intIndex, 1)
 
−
    Next
 
−
    Exit Sub
 
−
   
 
−
handleGetAllSettingsError:
 
−
    Debug.Print "No user settings available."
 
−
End Sub
 
−
 
 
−
=== deleteUserSettings ===
 
−
Sub deleteUserSettings()
 
−
    Debug.Print
 
−
    Debug.Print "User Settings"
 
−
    Debug.Print "-------------"
 
−
    On Error Resume Next
 
−
    DeleteSetting getProjectName
 
−
    Debug.Print "All user settings deleted."
 
−
End Sub
 
−
 
−
 
 
−
== modUi ==
 
−
 
 
−
=== setStatus ===
 
−
Public Sub setStatus(Optional strMessage As String = "Bereit")
 
−
    strMessage = _
 
−
        getUserName & " - " & _
 
−
        strMessage
 
−
    SysCmd acSysCmdSetStatus, strMessage
 
−
End Sub
 
−
 
 
−
 
 
−
== modFunction ==
 
−
 
 
−
=== Round2 ===
 
−
Microsoft Access' Round() function is different from the one implemented in Microsoft Excel. The behavious can be imitated using a user defined function.
 
−
 
 
−
Public Function Round2(dblValue As Double, intDecimal As Integer) As Double
 
−
    Dim dblResult As Double
 
−
   
 
−
    dblResult = CLng(dblValue * 10 ^ intDecimal) / 10 ^ intDecimal
 
−
   
 
−
    Round2 = dblResult
 
−
End Function
 
−
 
 
−
== modSql ==
 
−
 
 
−
=== Constants ===
 
−
Public Const strFormatSqlDate As String = "yyyy\-mm\-dd"
 
−
Public Const strFormatSqlDateCriterion As String = "\#yyyy\-mm\-dd\#"
 
−
 
 
−
=== executeSql ===
 
−
Public Function executeSql(strSql As String) As Long
 
−
    Dim lngResult As Long
 
−
   
 
−
    Const strFormatHms As String = "hh:mm:ss"
 
−
   
 
−
    Dim datStart As Date
 
−
   
 
−
    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
 
−
 
 
−
=== 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
 
−
    Set qdf = Nothing
 
−
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 ==
 
−
 
 
−
=== assurePath ===
 
−
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
 
−
 
 
−
 
 
−
== modWsh ==
 
−
Windows Scripting Host Object based methods
 
−
 
 
−
=== getUserName ===
 
−
Function getUserName() As String
 
−
    Dim strResult As String
 
−
   
 
−
    Dim wshNet As WshNetwork
 
−
   
 
−
    Set wshNet = New WshNetwork
 
−
    strResult = wshNet.UserName
 
−
   
 
−
    getUserName = strResult
 
−
End Function
 
−
 
−
=== getComputerName ===
 
−
Function getComputerName() As String
 
−
    Dim strResult As String
 
−
   
 
−
    Dim wshNet As WshNetwork
 
−
   
 
−
    Set wshNet = New WshNetwork
 
−
    strResult = wshNet.ComputerName
 
−
   
 
−
    getComputerName = strResult
 
−
End Function
 
−
 
 
−
== modExcel ==
 
−
 
 
−
=== Variables ===
 
−
Private xl As Excel.Application
 
−
Private blnCreated As Boolean
 
−
 
 
−
=== getExcel ===
 
−
Private Function getExcel() As Excel.Application
 
−
    If xl Is Nothing Then
 
−
        On Error Resume Next
 
−
        Set xl = GetObject(, "Excel.Application")
 
−
        On Error GoTo 0
 
−
        If xl Is Nothing Then
 
−
            Set xl = CreateObject("Excel.Application")
 
−
            xl.Visible = True
 
−
            blnCreated = True
 
−
        Else
 
−
            blnCreated = False
 
−
        End If
 
−
    End If
 
−
   
 
−
    Set getExcel = xl
 
−
End Function
 
−
 
 
−
=== quitExcel ===
 
−
Sub quitExcel()
 
−
    With xl
 
−
        If blnCreated Then
 
−
            .Quit
 
−
        End If
 
−
        Set xl = Nothing
 
−
    End With
 
−
End Sub
 
−
 
 
−
=== openExcelWorkbook ===
 
−
Public Function openExcelWorkbook(strPathFile As String) As Excel.Workbook
 
−
    Dim wbkResult As Excel.Workbook
 
−
   
 
−
    With getExcel
 
−
        Set wbkResult = .Workbooks.Open(strPathFile)
 
−
    End With
 
−
   
 
−
    Set openExcelWorkbook = wbkResult
 
−
End Function
 
−
 
 
−
=== closeExcelWorkbook ===
 
−
Public Sub closeExcelWorkbook(strWorkbook As String, Optional blnQuit As Boolean = False)
 
−
    With xl
 
−
        .Workbooks(strWorkbook).Close
 
−
        If blnQuit Then
 
−
            quitExcel
 
−
        End If
 
−
    End With
 
−
End Sub
 

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"