How to make parametrized update statement [duplicate] - vba

I've read a lot about SQL injection, and using parameters, from sources like bobby-tables.com. However, I'm working with a complex application in Access, that has a lot of dynamic SQL with string concatenation in all sorts of places.
It has the following things I want to change, and add parameters to, to avoid errors and allow me to handle names with single quotes, like Jack O'Connel.
It uses:
DoCmd.RunSQL to execute SQL commands
DAO recordsets
ADODB recordsets
Forms and reports, opened with DoCmd.OpenForm and DoCmd.OpenReport, using string concatenation in the WhereCondition argument
Domain aggregates like DLookUp that use string concatenation
The queries are mostly structured like this:
DoCmd.RunSQL "INSERT INTO Table1(Field1) SELECT Field1 FROM Table2 WHERE ID = " & Me.SomeTextbox
What are my options to use parameters for these different kinds of queries?
This question is intended as a resource, for the frequent how do I use parameters comment on various posts

There are many ways to use parameters in queries. I will try to provide examples for most of them, and where they are applicable.
First, we'll discuss the solutions unique to Access, such as forms, reports and domain aggregates. Then, we'll talk about DAO and ADO.
Using values from forms and reports as parameters
In Access, you can directly use the current value of controls on forms and reports in your SQL code. This limits the need for parameters.
You can refer to controls in the following way:
Forms!MyForm!MyTextbox for a simple control on a form
Forms!MyForm!MySubform.Form!MyTextbox for a control on a subform
Reports!MyReport!MyTextbox for a control on a report
Sample implementation:
DoCmd.RunSQL "INSERT INTO Table1(Field1) SELECT Forms!MyForm!MyTextbox" 'Inserts a single value
DoCmd.RunSQL "INSERT INTO Table1(Field1) SELECT Field1 FROM Table2 WHERE ID = Forms!MyForm!MyTextbox" 'Inserts from a different table
This is available for the following uses:
When using DoCmd.RunSQL, normal queries (in the GUI), form and report record sources, form and report filters, domain aggregates, DoCmd.OpenForm and DoCmd.OpenReport
This is not available for the following uses:
When executing queries using DAO or ADODB (e.g. opening recordsets, CurrentDb.Execute)
Using TempVars as parameters
TempVars in Access are globally available variables, that can be set in VBA or using macro's. They can be reused for multiple queries.
Sample implementation:
TempVars!MyTempVar = Me.MyTextbox.Value 'Note: .Value is required
DoCmd.RunSQL "INSERT INTO Table1(Field1) SELECT Field1 FROM Table2 WHERE ID = TempVars!MyTempVar"
TempVars.Remove "MyTempVar" 'Unset TempVar when you're done using it
Availability for TempVars is identical to that of values from forms and reports: not available for ADO and DAO, available for other uses.
I recommend TempVars for using parameters when opening forms or reports over referring to control names, since if the object opening it closes, the TempVars stay available. I recommend using unique TempVar names for every form or report, to avoid weirdness when refreshing forms or reports.
Using custom functions (UDFs) as parameters
Much like TempVars, you can use a custom function and static variables to store and retrieve values.
Sample implementation:
Option Compare Database
Option Explicit
Private ThisDate As Date
Public Function GetThisDate() As Date
If ThisDate = #12:00:00 AM# Then
' Set default value.
ThisDate = Date
End If
GetThisDate = ThisDate
End Function
Public Function SetThisDate(ByVal NewDate As Date) As Date
ThisDate = NewDate
SetThisDate = ThisDate
End Function
and then:
SetThisDate SomeDateValue ' Will store SomeDateValue in ThisDate.
DoCmd.RunSQL "INSERT INTO Table1(Field1) SELECT Field1 FROM Table2 WHERE [SomeDateField] = GetThisDate()"
Also, a single function with an optional parameter may be created for both setting and getting the value of a private static variable:
Public Function ThisValue(Optional ByVal Value As Variant) As Variant
Static CurrentValue As Variant
' Define default return value.
Const DefaultValue As Variant = Null
If Not IsMissing(Value) Then
' Set value.
CurrentValue = Value
ElseIf IsEmpty(CurrentValue) Then
' Set default value
CurrentValue = DefaultValue
End If
' Return value.
ThisValue = CurrentValue
End Function
To set a value:
ThisValue "Some text value"
To get the value:
CurrentValue = ThisValue
In a query:
ThisValue "SomeText" ' Set value to filter on.
DoCmd.RunSQL "INSERT INTO Table1(Field1) SELECT Field1 FROM Table2 WHERE [SomeField] = ThisValue()"
Using DoCmd.SetParameter
The uses of DoCmd.SetParameter are rather limited, so I'll be brief. It allows you to set a parameter for use in DoCmd.OpenForm, DoCmd.OpenReport and some other DoCmd statements, but it doesn't work with DoCmd.RunSQL, filters, DAO and ADO.
Sample implementation
DoCmd.SetParameter "MyParameter", Me.MyTextbox
DoCmd.OpenForm "MyForm",,, "ID = MyParameter"
Using DAO
In DAO, we can use the DAO.QueryDef object to create a query, set parameters, and then either open up a recordset or execute the query. You first set the queries' SQL, then use the QueryDef.Parameters collection to set the parameters.
In my example, I'm going to use implicit parameter types. If you want to make them explicit, add a PARAMETERS declaration to your query.
Sample implementation
'Execute query, unnamed parameters
With CurrentDb.CreateQueryDef("", "INSERT INTO Table1(Field1) SELECT Field1 FROM Table2 WHERE Field1 = ?p1 And Field2 = ?p2")
.Parameters(0) = Me.Field1
.Parameters(1) = Me.Field2
.Execute
End With
'Open recordset, named parameters
Dim rs As DAO.Recordset
With CurrentDb.CreateQueryDef("", "SELECT Field1 FROM Table2 WHERE Field1 = FirstParameter And Field2 = SecondParameter")
.Parameters!FirstParameter = Me.Field1 'Bang notation
.Parameters("SecondParameter").Value = Me.Field2 'More explicit notation
Set rs = .OpenRecordset
End With
While this is only available in DAO, you can set many things to DAO recordsets to make them use parameters, such as form recordsets, list box recordsets and combo box recordsets. However, since Access uses the text, and not the recordset, when sorting and filtering, those things may prove problematic if you do.
Using ADO
You can use parameters in ADO by using the ADODB.Command object. Use Command.CreateParameter to create parameters, and then append them to the Command.Parameters collection.
You can use the .Parameters collection in ADO to explicitly declare parameters, or pass a parameter array to the Command.Execute method to implicitly pass parameters.
ADO does not support named parameters. While you can pass a name, it's not processed.
Sample implementation:
'Execute query, unnamed parameters
Dim cmd As ADODB.Command
Set cmd = New ADODB.Command
With cmd
Set .ActiveConnection = CurrentProject.Connection 'Use a connection to the current database
.CommandText = "INSERT INTO Table1(Field1) SELECT Field1 FROM Table2 WHERE Field1 = ? And Field2 = ?"
.Parameters.Append .CreateParameter(, adVarWChar, adParamInput, Len(Me.Field1), Me.Field1) 'adVarWChar for text boxes that may contain unicode
.Parameters.Append .CreateParameter(, adInteger, adParamInput, 8, Me.Field2) 'adInteger for whole numbers (long or integer)
.Execute
End With
'Open recordset, implicit parameters
Dim rs As ADODB.Recordset
Dim cmd As ADODB.Command
Set cmd = New ADODB.Command
With cmd
Set .ActiveConnection = CurrentProject.Connection 'Use a connection to the current database
.CommandText = "SELECT Field1 FROM Table2 WHERE Field1 = #FirstParameter And Field2 = #SecondParameter"
Set rs = .Execute(,Array(Me.Field1, Me.Field2))
End With
The same limitations as opening DAO recordsets apply. While this way is limited to executing queries and opening recordsets, you can use those recordsets elsewhere in your application.

I have built a fairly basic query builder class to get around the mess of string concatenation and to handle the lack of named parameters. Creating a query is fairly simple.
Public Function GetQuery() As String
With New MSAccessQueryBuilder
.QueryBody = "SELECT * FROM tblEmployees"
.AddPredicate "StartDate > #StartDate OR StatusChangeDate > #StartDate"
.AddPredicate "StatusIndicator IN (#Active, #LeaveOfAbsence) OR Grade > #Grade"
.AddPredicate "Salary > #SalaryThreshhold"
.AddPredicate "Retired = #IsRetired"
.AddStringParameter "Active", "A"
.AddLongParameter "Grade", 10
.AddBooleanParameter "IsRetired", False
.AddStringParameter "LeaveOfAbsence", "L"
.AddCurrencyParameter "SalaryThreshhold", 9999.99#
.AddDateParameter "StartDate", #3/29/2018#
.QueryFooter = "ORDER BY ID ASC"
GetQuery = .ToString
End With
End Function
The output of the ToString() method looks like:
SELECT * FROM tblEmployees WHERE 1 = 1 AND (StartDate > #3/29/2018# OR StatusChangeDate > #3/29/2018#) AND (StatusIndicator IN ('A', 'L') OR Grade > 10) AND (Salary > 9999.99) AND (Retired = False) ORDER BY ID ASC;
Each predicate is wrapped in parens to handle linked AND/OR clauses, and parameters with the same name only have to be declared once. Full code is at my github and reproduced below. I also have a version for Oracle passthrough queries that uses ADODB parameters. Eventually, I'd like to wrap both in an IQueryBuilder interface.
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "MSAccessQueryBuilder"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
'#Folder("VBALibrary.Data")
'#Description("Provides tools to construct Microsoft Access SQL statements containing predicates and parameters.")
Option Explicit
Private Const mlngErrorNumber As Long = vbObjectError + 513
Private Const mstrClassName As String = "MSAccessQueryBuilder"
Private Const mstrParameterExistsErrorMessage As String = "A parameter with this name has already been added to the Parameters dictionary."
Private Type TSqlBuilder
QueryBody As String
QueryFooter As String
End Type
Private mobjParameters As Object
Private mobjPredicates As Collection
Private this As TSqlBuilder
' =============================================================================
' CONSTRUCTOR / DESTRUCTOR
' =============================================================================
Private Sub Class_Initialize()
Set mobjParameters = CreateObject("Scripting.Dictionary")
Set mobjPredicates = New Collection
End Sub
' =============================================================================
' PROPERTIES
' =============================================================================
'#Description("Gets or sets the query statement (SELECT, INSERT, UPDATE, DELETE), exclusive of any predicates.")
Public Property Get QueryBody() As String
QueryBody = this.QueryBody
End Property
Public Property Let QueryBody(ByVal Value As String)
this.QueryBody = Value
End Property
'#Description("Gets or sets post-predicate query statements (e.g., GROUP BY, ORDER BY).")
Public Property Get QueryFooter() As String
QueryFooter = this.QueryFooter
End Property
Public Property Let QueryFooter(ByVal Value As String)
this.QueryFooter = Value
End Property
' =============================================================================
' PUBLIC METHODS
' =============================================================================
'#Description("Maps a boolean parameter and its value to the query builder.")
'#Param("strName: The parameter's name.")
'#Param("blnValue: The parameter's value.")
Public Sub AddBooleanParameter(ByVal strName As String, ByVal blnValue As Boolean)
If mobjParameters.Exists(strName) Then
Err.Raise mlngErrorNumber, mstrClassName & ".AddBooleanParameter", mstrParameterExistsErrorMessage
Else
mobjParameters.Add strName, CStr(blnValue)
End If
End Sub
' =============================================================================
'#Description("Maps a currency parameter and its value to the query builder.")
'#Param("strName: The parameter's name.")
'#Param("curValue: The parameter's value.")
Public Sub AddCurrencyParameter(ByVal strName As String, ByVal curValue As Currency)
If mobjParameters.Exists(strName) Then
Err.Raise mlngErrorNumber, mstrClassName & ".AddCurrencyParameter", mstrParameterExistsErrorMessage
Else
mobjParameters.Add strName, CStr(curValue)
End If
End Sub
' =============================================================================
'#Description("Maps a date parameter and its value to the query builder.")
'#Param("strName: The parameter's name.")
'#Param("dtmValue: The parameter's value.")
Public Sub AddDateParameter(ByVal strName As String, ByVal dtmValue As Date)
If mobjParameters.Exists(strName) Then
Err.Raise mlngErrorNumber, mstrClassName & ".AddDateParameter", mstrParameterExistsErrorMessage
Else
mobjParameters.Add strName, "#" & CStr(dtmValue) & "#"
End If
End Sub
' =============================================================================
'#Description("Maps a long parameter and its value to the query builder.")
'#Param("strName: The parameter's name.")
'#Param("lngValue: The parameter's value.")
Public Sub AddLongParameter(ByVal strName As String, ByVal lngValue As Long)
If mobjParameters.Exists(strName) Then
Err.Raise mlngErrorNumber, mstrClassName & ".AddNumericParameter", mstrParameterExistsErrorMessage
Else
mobjParameters.Add strName, CStr(lngValue)
End If
End Sub
' =============================================================================
'#Description("Adds a predicate to the query's WHERE criteria.")
'#Param("strPredicate: The predicate text to be added.")
Public Sub AddPredicate(ByVal strPredicate As String)
mobjPredicates.Add "(" & strPredicate & ")"
End Sub
' =============================================================================
'#Description("Maps a string parameter and its value to the query builder.")
'#Param("strName: The parameter's name.")
'#Param("strValue: The parameter's value.")
Public Sub AddStringParameter(ByVal strName As String, ByVal strValue As String)
If mobjParameters.Exists(strName) Then
Err.Raise mlngErrorNumber, mstrClassName & ".AddStringParameter", mstrParameterExistsErrorMessage
Else
mobjParameters.Add strName, "'" & strValue & "'"
End If
End Sub
' =============================================================================
'#Description("Parses the query, its predicates, and any parameter values, and outputs an SQL statement.")
'#Returns("A string containing the parsed query.")
Public Function ToString() As String
Dim strPredicatesWithValues As String
Const strErrorSource As String = "QueryBuilder.ToString"
If this.QueryBody = vbNullString Then
Err.Raise mlngErrorNumber, strErrorSource, "No query body is currently defined. Unable to build valid SQL."
End If
ToString = this.QueryBody
strPredicatesWithValues = ReplaceParametersWithValues(GetPredicatesText)
EnsureParametersHaveValues strPredicatesWithValues
If Not strPredicatesWithValues = vbNullString Then
ToString = ToString & " " & strPredicatesWithValues
End If
If Not this.QueryFooter = vbNullString Then
ToString = ToString & " " & this.QueryFooter & ";"
End If
End Function
' =============================================================================
' PRIVATE METHODS
' =============================================================================
'#Description("Ensures that all parameters defined in the query have been provided a value.")
'#Param("strQueryText: The query text to verify.")
Private Sub EnsureParametersHaveValues(ByVal strQueryText As String)
Dim strUnmatchedParameter As String
Dim lngMatchedPoisition As Long
Dim lngWordEndPosition As Long
Const strProcedureName As String = "EnsureParametersHaveValues"
lngMatchedPoisition = InStr(1, strQueryText, "#", vbTextCompare)
If lngMatchedPoisition <> 0 Then
lngWordEndPosition = InStr(lngMatchedPoisition, strQueryText, Space$(1), vbTextCompare)
strUnmatchedParameter = Mid$(strQueryText, lngMatchedPoisition, lngWordEndPosition - lngMatchedPoisition)
End If
If Not strUnmatchedParameter = vbNullString Then
Err.Raise mlngErrorNumber, mstrClassName & "." & strProcedureName, "Parameter " & strUnmatchedParameter & " has not been provided a value."
End If
End Sub
' =============================================================================
'#Description("Combines each predicate in the predicates collection into a single string statement.")
'#Returns("A string containing the text of all predicates added to the query builder.")
Private Function GetPredicatesText() As String
Dim strPredicates As String
Dim vntPredicate As Variant
If mobjPredicates.Count > 0 Then
strPredicates = "WHERE 1 = 1"
For Each vntPredicate In mobjPredicates
strPredicates = strPredicates & " AND " & CStr(vntPredicate)
Next vntPredicate
End If
GetPredicatesText = strPredicates
End Function
' =============================================================================
'#Description("Replaces parameters in the predicates statements with their provided values.")
'#Param("strPredicates: The text of the query's predicates.")
'#Returns("A string containing the predicates text with its parameters replaces by their provided values.")
Private Function ReplaceParametersWithValues(ByVal strPredicates As String) As String
Dim vntKey As Variant
Dim strParameterName As String
Dim strParameterValue As String
Dim strPredicatesWithValues As String
Const strProcedureName As String = "ReplaceParametersWithValues"
strPredicatesWithValues = strPredicates
For Each vntKey In mobjParameters.Keys
strParameterName = CStr(vntKey)
strParameterValue = CStr(mobjParameters(vntKey))
If InStr(1, strPredicatesWithValues, "#" & strParameterName, vbTextCompare) = 0 Then
Err.Raise mlngErrorNumber, mstrClassName & "." & strProcedureName, "Parameter " & strParameterName & " was not found in the query."
Else
strPredicatesWithValues = Replace(strPredicatesWithValues, "#" & strParameterName, strParameterValue, 1, -1, vbTextCompare)
End If
Next vntKey
ReplaceParametersWithValues = strPredicatesWithValues
End Function
' =============================================================================

Related

Data Type Mismatch on SQL statement

I am trying to pull in column data from a table into a timer in VBA. In my table I have IntervalSeconds as a number. I'm trying to query the number of seconds to determine how long to set my counter for.
Dim timeRemaining As Long (Form Variable) - used in multiple functionss
Private Sub Form_Open(Cancel As Integer)
Dim strSQL As String
Me.Visible = False
strSQL = "SELECT AccessControl.IntervalSeconds FROM AccessControl WHERE AccessControl.DatabaseName = '" & CurrentDb.Name & "'"
timeRemaining = CLng(strSQL)
DoCmd.OpenForm ("frmForceLogout")
End Sub
Every time I run the form I get a Type Mismatch error when I hit the timeRemaining = cLng(strSQL) line. Am I missing something?
You can use DLookup for such simple tasks:
Private Sub Form_Open(Cancel As Integer)
Dim Criteria As String
Me.Visible = False
Criteria = "DatabaseName = '" & CurrentDb.Name & "'"
timeRemaining = DLookup("IntervalSeconds", "AccessControl", Criteria)
DoCmd.OpenForm ("frmForceLogout")
End Sub

DoCmd.RunSQL "INSERT INTO TABLE" Numeric Values missing [duplicate]

I've read a lot about SQL injection, and using parameters, from sources like bobby-tables.com. However, I'm working with a complex application in Access, that has a lot of dynamic SQL with string concatenation in all sorts of places.
It has the following things I want to change, and add parameters to, to avoid errors and allow me to handle names with single quotes, like Jack O'Connel.
It uses:
DoCmd.RunSQL to execute SQL commands
DAO recordsets
ADODB recordsets
Forms and reports, opened with DoCmd.OpenForm and DoCmd.OpenReport, using string concatenation in the WhereCondition argument
Domain aggregates like DLookUp that use string concatenation
The queries are mostly structured like this:
DoCmd.RunSQL "INSERT INTO Table1(Field1) SELECT Field1 FROM Table2 WHERE ID = " & Me.SomeTextbox
What are my options to use parameters for these different kinds of queries?
This question is intended as a resource, for the frequent how do I use parameters comment on various posts
There are many ways to use parameters in queries. I will try to provide examples for most of them, and where they are applicable.
First, we'll discuss the solutions unique to Access, such as forms, reports and domain aggregates. Then, we'll talk about DAO and ADO.
Using values from forms and reports as parameters
In Access, you can directly use the current value of controls on forms and reports in your SQL code. This limits the need for parameters.
You can refer to controls in the following way:
Forms!MyForm!MyTextbox for a simple control on a form
Forms!MyForm!MySubform.Form!MyTextbox for a control on a subform
Reports!MyReport!MyTextbox for a control on a report
Sample implementation:
DoCmd.RunSQL "INSERT INTO Table1(Field1) SELECT Forms!MyForm!MyTextbox" 'Inserts a single value
DoCmd.RunSQL "INSERT INTO Table1(Field1) SELECT Field1 FROM Table2 WHERE ID = Forms!MyForm!MyTextbox" 'Inserts from a different table
This is available for the following uses:
When using DoCmd.RunSQL, normal queries (in the GUI), form and report record sources, form and report filters, domain aggregates, DoCmd.OpenForm and DoCmd.OpenReport
This is not available for the following uses:
When executing queries using DAO or ADODB (e.g. opening recordsets, CurrentDb.Execute)
Using TempVars as parameters
TempVars in Access are globally available variables, that can be set in VBA or using macro's. They can be reused for multiple queries.
Sample implementation:
TempVars!MyTempVar = Me.MyTextbox.Value 'Note: .Value is required
DoCmd.RunSQL "INSERT INTO Table1(Field1) SELECT Field1 FROM Table2 WHERE ID = TempVars!MyTempVar"
TempVars.Remove "MyTempVar" 'Unset TempVar when you're done using it
Availability for TempVars is identical to that of values from forms and reports: not available for ADO and DAO, available for other uses.
I recommend TempVars for using parameters when opening forms or reports over referring to control names, since if the object opening it closes, the TempVars stay available. I recommend using unique TempVar names for every form or report, to avoid weirdness when refreshing forms or reports.
Using custom functions (UDFs) as parameters
Much like TempVars, you can use a custom function and static variables to store and retrieve values.
Sample implementation:
Option Compare Database
Option Explicit
Private ThisDate As Date
Public Function GetThisDate() As Date
If ThisDate = #12:00:00 AM# Then
' Set default value.
ThisDate = Date
End If
GetThisDate = ThisDate
End Function
Public Function SetThisDate(ByVal NewDate As Date) As Date
ThisDate = NewDate
SetThisDate = ThisDate
End Function
and then:
SetThisDate SomeDateValue ' Will store SomeDateValue in ThisDate.
DoCmd.RunSQL "INSERT INTO Table1(Field1) SELECT Field1 FROM Table2 WHERE [SomeDateField] = GetThisDate()"
Also, a single function with an optional parameter may be created for both setting and getting the value of a private static variable:
Public Function ThisValue(Optional ByVal Value As Variant) As Variant
Static CurrentValue As Variant
' Define default return value.
Const DefaultValue As Variant = Null
If Not IsMissing(Value) Then
' Set value.
CurrentValue = Value
ElseIf IsEmpty(CurrentValue) Then
' Set default value
CurrentValue = DefaultValue
End If
' Return value.
ThisValue = CurrentValue
End Function
To set a value:
ThisValue "Some text value"
To get the value:
CurrentValue = ThisValue
In a query:
ThisValue "SomeText" ' Set value to filter on.
DoCmd.RunSQL "INSERT INTO Table1(Field1) SELECT Field1 FROM Table2 WHERE [SomeField] = ThisValue()"
Using DoCmd.SetParameter
The uses of DoCmd.SetParameter are rather limited, so I'll be brief. It allows you to set a parameter for use in DoCmd.OpenForm, DoCmd.OpenReport and some other DoCmd statements, but it doesn't work with DoCmd.RunSQL, filters, DAO and ADO.
Sample implementation
DoCmd.SetParameter "MyParameter", Me.MyTextbox
DoCmd.OpenForm "MyForm",,, "ID = MyParameter"
Using DAO
In DAO, we can use the DAO.QueryDef object to create a query, set parameters, and then either open up a recordset or execute the query. You first set the queries' SQL, then use the QueryDef.Parameters collection to set the parameters.
In my example, I'm going to use implicit parameter types. If you want to make them explicit, add a PARAMETERS declaration to your query.
Sample implementation
'Execute query, unnamed parameters
With CurrentDb.CreateQueryDef("", "INSERT INTO Table1(Field1) SELECT Field1 FROM Table2 WHERE Field1 = ?p1 And Field2 = ?p2")
.Parameters(0) = Me.Field1
.Parameters(1) = Me.Field2
.Execute
End With
'Open recordset, named parameters
Dim rs As DAO.Recordset
With CurrentDb.CreateQueryDef("", "SELECT Field1 FROM Table2 WHERE Field1 = FirstParameter And Field2 = SecondParameter")
.Parameters!FirstParameter = Me.Field1 'Bang notation
.Parameters("SecondParameter").Value = Me.Field2 'More explicit notation
Set rs = .OpenRecordset
End With
While this is only available in DAO, you can set many things to DAO recordsets to make them use parameters, such as form recordsets, list box recordsets and combo box recordsets. However, since Access uses the text, and not the recordset, when sorting and filtering, those things may prove problematic if you do.
Using ADO
You can use parameters in ADO by using the ADODB.Command object. Use Command.CreateParameter to create parameters, and then append them to the Command.Parameters collection.
You can use the .Parameters collection in ADO to explicitly declare parameters, or pass a parameter array to the Command.Execute method to implicitly pass parameters.
ADO does not support named parameters. While you can pass a name, it's not processed.
Sample implementation:
'Execute query, unnamed parameters
Dim cmd As ADODB.Command
Set cmd = New ADODB.Command
With cmd
Set .ActiveConnection = CurrentProject.Connection 'Use a connection to the current database
.CommandText = "INSERT INTO Table1(Field1) SELECT Field1 FROM Table2 WHERE Field1 = ? And Field2 = ?"
.Parameters.Append .CreateParameter(, adVarWChar, adParamInput, Len(Me.Field1), Me.Field1) 'adVarWChar for text boxes that may contain unicode
.Parameters.Append .CreateParameter(, adInteger, adParamInput, 8, Me.Field2) 'adInteger for whole numbers (long or integer)
.Execute
End With
'Open recordset, implicit parameters
Dim rs As ADODB.Recordset
Dim cmd As ADODB.Command
Set cmd = New ADODB.Command
With cmd
Set .ActiveConnection = CurrentProject.Connection 'Use a connection to the current database
.CommandText = "SELECT Field1 FROM Table2 WHERE Field1 = #FirstParameter And Field2 = #SecondParameter"
Set rs = .Execute(,Array(Me.Field1, Me.Field2))
End With
The same limitations as opening DAO recordsets apply. While this way is limited to executing queries and opening recordsets, you can use those recordsets elsewhere in your application.
I have built a fairly basic query builder class to get around the mess of string concatenation and to handle the lack of named parameters. Creating a query is fairly simple.
Public Function GetQuery() As String
With New MSAccessQueryBuilder
.QueryBody = "SELECT * FROM tblEmployees"
.AddPredicate "StartDate > #StartDate OR StatusChangeDate > #StartDate"
.AddPredicate "StatusIndicator IN (#Active, #LeaveOfAbsence) OR Grade > #Grade"
.AddPredicate "Salary > #SalaryThreshhold"
.AddPredicate "Retired = #IsRetired"
.AddStringParameter "Active", "A"
.AddLongParameter "Grade", 10
.AddBooleanParameter "IsRetired", False
.AddStringParameter "LeaveOfAbsence", "L"
.AddCurrencyParameter "SalaryThreshhold", 9999.99#
.AddDateParameter "StartDate", #3/29/2018#
.QueryFooter = "ORDER BY ID ASC"
GetQuery = .ToString
End With
End Function
The output of the ToString() method looks like:
SELECT * FROM tblEmployees WHERE 1 = 1 AND (StartDate > #3/29/2018# OR StatusChangeDate > #3/29/2018#) AND (StatusIndicator IN ('A', 'L') OR Grade > 10) AND (Salary > 9999.99) AND (Retired = False) ORDER BY ID ASC;
Each predicate is wrapped in parens to handle linked AND/OR clauses, and parameters with the same name only have to be declared once. Full code is at my github and reproduced below. I also have a version for Oracle passthrough queries that uses ADODB parameters. Eventually, I'd like to wrap both in an IQueryBuilder interface.
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "MSAccessQueryBuilder"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
'#Folder("VBALibrary.Data")
'#Description("Provides tools to construct Microsoft Access SQL statements containing predicates and parameters.")
Option Explicit
Private Const mlngErrorNumber As Long = vbObjectError + 513
Private Const mstrClassName As String = "MSAccessQueryBuilder"
Private Const mstrParameterExistsErrorMessage As String = "A parameter with this name has already been added to the Parameters dictionary."
Private Type TSqlBuilder
QueryBody As String
QueryFooter As String
End Type
Private mobjParameters As Object
Private mobjPredicates As Collection
Private this As TSqlBuilder
' =============================================================================
' CONSTRUCTOR / DESTRUCTOR
' =============================================================================
Private Sub Class_Initialize()
Set mobjParameters = CreateObject("Scripting.Dictionary")
Set mobjPredicates = New Collection
End Sub
' =============================================================================
' PROPERTIES
' =============================================================================
'#Description("Gets or sets the query statement (SELECT, INSERT, UPDATE, DELETE), exclusive of any predicates.")
Public Property Get QueryBody() As String
QueryBody = this.QueryBody
End Property
Public Property Let QueryBody(ByVal Value As String)
this.QueryBody = Value
End Property
'#Description("Gets or sets post-predicate query statements (e.g., GROUP BY, ORDER BY).")
Public Property Get QueryFooter() As String
QueryFooter = this.QueryFooter
End Property
Public Property Let QueryFooter(ByVal Value As String)
this.QueryFooter = Value
End Property
' =============================================================================
' PUBLIC METHODS
' =============================================================================
'#Description("Maps a boolean parameter and its value to the query builder.")
'#Param("strName: The parameter's name.")
'#Param("blnValue: The parameter's value.")
Public Sub AddBooleanParameter(ByVal strName As String, ByVal blnValue As Boolean)
If mobjParameters.Exists(strName) Then
Err.Raise mlngErrorNumber, mstrClassName & ".AddBooleanParameter", mstrParameterExistsErrorMessage
Else
mobjParameters.Add strName, CStr(blnValue)
End If
End Sub
' =============================================================================
'#Description("Maps a currency parameter and its value to the query builder.")
'#Param("strName: The parameter's name.")
'#Param("curValue: The parameter's value.")
Public Sub AddCurrencyParameter(ByVal strName As String, ByVal curValue As Currency)
If mobjParameters.Exists(strName) Then
Err.Raise mlngErrorNumber, mstrClassName & ".AddCurrencyParameter", mstrParameterExistsErrorMessage
Else
mobjParameters.Add strName, CStr(curValue)
End If
End Sub
' =============================================================================
'#Description("Maps a date parameter and its value to the query builder.")
'#Param("strName: The parameter's name.")
'#Param("dtmValue: The parameter's value.")
Public Sub AddDateParameter(ByVal strName As String, ByVal dtmValue As Date)
If mobjParameters.Exists(strName) Then
Err.Raise mlngErrorNumber, mstrClassName & ".AddDateParameter", mstrParameterExistsErrorMessage
Else
mobjParameters.Add strName, "#" & CStr(dtmValue) & "#"
End If
End Sub
' =============================================================================
'#Description("Maps a long parameter and its value to the query builder.")
'#Param("strName: The parameter's name.")
'#Param("lngValue: The parameter's value.")
Public Sub AddLongParameter(ByVal strName As String, ByVal lngValue As Long)
If mobjParameters.Exists(strName) Then
Err.Raise mlngErrorNumber, mstrClassName & ".AddNumericParameter", mstrParameterExistsErrorMessage
Else
mobjParameters.Add strName, CStr(lngValue)
End If
End Sub
' =============================================================================
'#Description("Adds a predicate to the query's WHERE criteria.")
'#Param("strPredicate: The predicate text to be added.")
Public Sub AddPredicate(ByVal strPredicate As String)
mobjPredicates.Add "(" & strPredicate & ")"
End Sub
' =============================================================================
'#Description("Maps a string parameter and its value to the query builder.")
'#Param("strName: The parameter's name.")
'#Param("strValue: The parameter's value.")
Public Sub AddStringParameter(ByVal strName As String, ByVal strValue As String)
If mobjParameters.Exists(strName) Then
Err.Raise mlngErrorNumber, mstrClassName & ".AddStringParameter", mstrParameterExistsErrorMessage
Else
mobjParameters.Add strName, "'" & strValue & "'"
End If
End Sub
' =============================================================================
'#Description("Parses the query, its predicates, and any parameter values, and outputs an SQL statement.")
'#Returns("A string containing the parsed query.")
Public Function ToString() As String
Dim strPredicatesWithValues As String
Const strErrorSource As String = "QueryBuilder.ToString"
If this.QueryBody = vbNullString Then
Err.Raise mlngErrorNumber, strErrorSource, "No query body is currently defined. Unable to build valid SQL."
End If
ToString = this.QueryBody
strPredicatesWithValues = ReplaceParametersWithValues(GetPredicatesText)
EnsureParametersHaveValues strPredicatesWithValues
If Not strPredicatesWithValues = vbNullString Then
ToString = ToString & " " & strPredicatesWithValues
End If
If Not this.QueryFooter = vbNullString Then
ToString = ToString & " " & this.QueryFooter & ";"
End If
End Function
' =============================================================================
' PRIVATE METHODS
' =============================================================================
'#Description("Ensures that all parameters defined in the query have been provided a value.")
'#Param("strQueryText: The query text to verify.")
Private Sub EnsureParametersHaveValues(ByVal strQueryText As String)
Dim strUnmatchedParameter As String
Dim lngMatchedPoisition As Long
Dim lngWordEndPosition As Long
Const strProcedureName As String = "EnsureParametersHaveValues"
lngMatchedPoisition = InStr(1, strQueryText, "#", vbTextCompare)
If lngMatchedPoisition <> 0 Then
lngWordEndPosition = InStr(lngMatchedPoisition, strQueryText, Space$(1), vbTextCompare)
strUnmatchedParameter = Mid$(strQueryText, lngMatchedPoisition, lngWordEndPosition - lngMatchedPoisition)
End If
If Not strUnmatchedParameter = vbNullString Then
Err.Raise mlngErrorNumber, mstrClassName & "." & strProcedureName, "Parameter " & strUnmatchedParameter & " has not been provided a value."
End If
End Sub
' =============================================================================
'#Description("Combines each predicate in the predicates collection into a single string statement.")
'#Returns("A string containing the text of all predicates added to the query builder.")
Private Function GetPredicatesText() As String
Dim strPredicates As String
Dim vntPredicate As Variant
If mobjPredicates.Count > 0 Then
strPredicates = "WHERE 1 = 1"
For Each vntPredicate In mobjPredicates
strPredicates = strPredicates & " AND " & CStr(vntPredicate)
Next vntPredicate
End If
GetPredicatesText = strPredicates
End Function
' =============================================================================
'#Description("Replaces parameters in the predicates statements with their provided values.")
'#Param("strPredicates: The text of the query's predicates.")
'#Returns("A string containing the predicates text with its parameters replaces by their provided values.")
Private Function ReplaceParametersWithValues(ByVal strPredicates As String) As String
Dim vntKey As Variant
Dim strParameterName As String
Dim strParameterValue As String
Dim strPredicatesWithValues As String
Const strProcedureName As String = "ReplaceParametersWithValues"
strPredicatesWithValues = strPredicates
For Each vntKey In mobjParameters.Keys
strParameterName = CStr(vntKey)
strParameterValue = CStr(mobjParameters(vntKey))
If InStr(1, strPredicatesWithValues, "#" & strParameterName, vbTextCompare) = 0 Then
Err.Raise mlngErrorNumber, mstrClassName & "." & strProcedureName, "Parameter " & strParameterName & " was not found in the query."
Else
strPredicatesWithValues = Replace(strPredicatesWithValues, "#" & strParameterName, strParameterValue, 1, -1, vbTextCompare)
End If
Next vntKey
ReplaceParametersWithValues = strPredicatesWithValues
End Function
' =============================================================================

How to check efficient whether a recordset value isnull before passing it to a called function?

I have a sub which creates a recordset. A function is called with values from the recordset. The goal is to use multiple values from the recordset, however, there is a possibility that a recordset value is null, then the function call will result in an error: "Invalid use of Null". To handle this error, each time the recordset value is checked for null values, if it is null, it will be replaced with an empty string. However, the way I have programmed this feels very inefficient, even more when later on more than ten parameters should be checked. Is there a way to do this more efficiently?
I have skipped the last part off the code as this is not necessary to understand my question. I've replaced it with ......... If needed, I will edit and provide full code.
Sub CallFunctionWithArray()
Dim conn As ADODB.Connection
Dim rst As ADODB.Recordset
Dim arrValues(1 To 3) As Variant
Set conn = New ADODB.Connection
conn.Open "provider=Microsoft.JET.OLEDB.4.0;Data Source=" & CurrentProject.Path & "\Northwind.mdb"
Set rst = New ADODB.Recordset
rst.Open "SELECT * FROM CustomersCopy", conn, adOpenForwardOnly, adLockReadOnly, adCmdText
If Not (rst.EOF And rst.BOF) Then
rst.MoveFirst
Do Until rst.EOF = True
If IsNull(rst![CompanyName]) Then
arrValues(1) = ""
Else
arrValues(1) = rst![CompanyName]
End If
If IsNull(rst![DateTest]) Then
arrValues(2) = ""
Else
arrValues(2) = rst![DateTest]
End If
If IsNull(rst![INTTest]) Then
arrValues(3) = ""
Else
arrValues(3) = rst![INTTest]
End If
Call ReturnValuesOfArray(arrValues(1), arrValues(2), arrValues(3))
.........
End Sub
Function ReturnValuesOfArray(ByVal ValueOne As String, ByVal ValueTwo As String, ByVal ValueThree As String)
Debug.Print "Waarde variabele 1: " & ValueOne
Debug.Print "Waarde variabele 2: " & ValueTwo
Debug.Print "Waarde variabele 3: " & ValueThree
End Function
There is no problem with the code, it does what it's supposed to do. However, I will be passing many more parameters to the function when this is going to be really used.
You could loop through the fields of your Recordset instead of hard coding for every field. Using your code as a starting point, it could look something like this:
Private Sub Test()
Dim rst As ADODB.Recordset
Dim i As Integer
If Not (rst.EOF And rst.BOF) Then
rst.MoveFirst
Do Until rst.EOF = True
For i = 0 To rst.Fields.Count - 1
If IsNull(rst.Fields(i).Value) Then
arrValues(i) = ""
Else
arrValues(i) = rst.Fields(i).Value
End If
Next
Loop
End If
End Sub
Incorporating the ideas presented by #HansUp and #Mathieu Guindon, the code is even shorter:
Private Sub Test()
Dim rst As ADODB.Recordset
Dim i As Integer
Do Until rst.EOF
For i = 0 To rst.Fields.Count - 1
arrValues(i + 1) = Nz(rst.Fields(i).Value, "")
Next
Loop
End Sub
The rest of your code can be simplified, too, while allowing for any number of parameters:
Function ReturnValuesOfArray(ByVal Values As Variant)
Dim i As Integer
For i = LBound(Values) To UBound(Values)
Debug.Print "Waarde variabele " & i & ": " & Values(i)
Next
End Function
The Nz Function does what I think you want.
arrValues(1) = Nz(rst![CompanyName], "")
arrValues(2) = Nz(rst![DateTest], "")
arrValues(3) = Nz(rst![INTTest], "")

how to calculate median in Access query using function in VBa

I'm using ms Access query to calculate the MEdian AGe of Patients grouped by Clinic name using Query.
since Access doesn't have build-in Median function. I have to create it using VBA,
I tried many ready functions from web.. but none worked properly. any suggestions for working codes around? could u plz help me to get the median! thank u in advance.
This is a good function also pretty well commented:
Public Function acbDMedian( _
ByVal strField As String, ByVal strDomain As String, _
Optional ByVal strCriteria As String) As Variant
' Purpose:
' To calculate the median value
' for a field in a table or query.
' In:
' strField: The field
' strDomain: The table or query
' strCriteria: An optional WHERE clause to
' apply to the table or query
' Out:
' Return value: The median, if successful;
' otherwise, an error value
Dim db As DAO.Database
Dim rstDomain As DAO.Recordset
Dim strSQL As String
Dim varMedian As Variant
Dim intFieldType As Integer
Dim intRecords As Integer
Const acbcErrAppTypeError = 3169
On Error GoTo HandleErr
Set db = CurrentDb( )
' Initialize the return value.
varMedian = Null
' Build a SQL string for the recordset.
strSQL = "SELECT " & strField
strSQL = strSQL & " FROM " & strDomain
' Use a WHERE clause only if one is passed in.
If Len(strCriteria) > 0 Then
strSQL = strSQL & " WHERE " & strCriteria
End If
strSQL = strSQL & " ORDER BY " & strField
Set rstDomain = db.OpenRecordset(strSQL, dbOpenSnapshot)
' Check the data type of the median field.
intFieldType = rstDomain.Fields(strField).Type
Select Case intFieldType
Case dbByte, dbInteger, dbLong, dbCurrency, dbSingle, dbDouble, dbDate
' Numeric field.
If Not rstDomain.EOF Then
rstDomain.MoveLast
intRecords = rstDomain.RecordCount
' Start from the first record.
rstDomain.MoveFirst
If (intRecords Mod 2) = 0 Then
' Even number of records. No middle record, so move
' to the record right before the middle.
rstDomain.Move ((intRecords \ 2) - 1)
varMedian = rstDomain.Fields(strField)
' Now move to the next record, the one right after
' the middle.
rstDomain.MoveNext
' Average the two values.
varMedian = (varMedian + rstDomain.Fields(strField)) / 2
' Make sure you return a date, even when averaging
' two dates.
If intFieldType = dbDate And Not IsNull(varMedian) Then
varMedian = CDate(varMedian)
End If
Else
' Odd number of records. Move to the middle record
' and return its value.
rstDomain.Move ((intRecords \ 2))
varMedian = rstDomain.Fields(strField)
End If
Else
' No records; return Null.
varMedian = Null
End If
Case Else
' Nonnumeric field; raise an app error.
Err.Raise acbcErrAppTypeError
End Select
acbDMedian = varMedian
ExitHere:
On Error Resume Next
rstDomain.Close
Set rstDomain = Nothing
Exit Function
HandleErr:
' Return an error value.
acbDMedian = CVErr(Err)
Resume ExitHere
End Function
Source: http://etutorials.org/Microsoft+Products/access/Chapter+6.+Data/Recipe+6.4+Find+the+Median+Value+for+a+Field/

VBA function to a field name

I have the same copy of a function in many forms that does exactly the same job. What changes in them is a field name. So the reason I keep it local is I don't know how I would refer to a particular field by name in a referenced form. This is the function:
Private Function getNewXNo(ByRef theForm As Form, ByVal strCode As String) As String
Dim rs As DAO.Recordset
Dim maxNo As Long
Dim aNo As Long
Set rs = theForm.RecordsetClone
maxNo = 0
If rs.RecordCount <> 0 Then
rs.MoveFirst
Do While Not rs.EOF
aNo = CLng(Right(Nz(rs!applicationNo, strCode & "0000"), 4))
If aNo > maxNo Then
maxNo = aNo
End If
rs.MoveNext
Loop
End If
getNewXNo = strCode & Format(maxNo + 1, "
Set rs = Nothing
End Function
There are a lot of instances when I have to generate new codes, such as BB001, BB002, APP001, APP002, etc. The function reads all existing codes from a field in the referenced form and based on that creates a new one. Is there any way I can send a field name to a global function, such as
aNo = CLng(Right(Nz(rs!varThatContainsAFieldName, strCode & "0000"), 4))
Thanks
You can access a field in a recordset like this:
rs("fieldname")
So you could make the field name a parameter for your function.