Search code examples
sqlvbams-access

Setting Parameters to VBA and SQL Query using DAO

So I am using buttons to run a query which then pulls the selected emails into an email. There is a singular function for this and then each button sends the corresponding query to act as the recordset

Sub EmailQuery(strQueryName As String)

'On Error GoTo Err_EmailRequery_Click

    Dim cn As ADODB.Connection
    Dim rs As ADODB.Recordset
    Dim strEmail As String

    Set cn = CurrentProject.Connection
    Set rs = New ADODB.Recordset

    rs.Open strQueryName, cn
    
    With rs
    .MoveLast
    .MoveFirst

        Do While Not .EOF
            strEmail = strEmail & .Fields("Email") & ";"
            .MoveNext
        Loop
        .Close
    End With
    
    strEmail = Left(strEmail, Len(strEmail) - 1)
    
    DoCmd.SendObject , , , , , strEmail, , , True, False
    
'Exit_EmailRequery_Click:
'
'    Exit Sub
'
'Err_EmailRequery_Click:
'
'    MsgBox Err.Description
'
'    Resume Exit_EmailRequery_Click

End Sub


Private Sub cmdActive_Click()

    EmailQuery ("qryActiveSuppliers")
    
End Sub

Private Sub cmdAllSuppliers_Click()
    
    EmailQuery ("qryAllSuppliers")

End Sub

Private Sub cmdArrangements_Click()
    
    EmailQuery ("qryAgreementEmail")

End Sub

Private Sub cmdInactive_Click()
    
    EmailQuery ("qryInactiveSuppliers")

End Sub

Form where the buttons are located All queries runs correctly just by clicking it in access and all bar the arrangements query run correctly. I took out the criteria from it's SQL statement to see if it would run and it did. The criteria is matched against the combobox selection on the form. Below is the SQL statement for the Arrangements button.

SELECT DISTINCT tblSuppliers.SupplierName, Nz([BusinessEmail],[PersonalEmail]) AS Email
FROM ((tblSuppliers 
INNER JOIN tblSuppliersAgreements ON tblSuppliers.ID = tblSuppliersAgreements.SupplierID) 
INNER JOIN tblContacts ON tblSuppliers.ID = tblContacts.SupplierID)
WHERE ((tblSuppliersAgreements.AgreementID)=[Forms]![frmMainMenu]![cboAgreement]);

This is the error I am getting when I try to click the button to run it

I think it may have something to do with the way I open the query in the rs.open line and I need to call the criteria not just in the SQL statement? Any help on this issue or a solution would be greatly appreciated.

Edit

So I have changed my code to this with DAO to see if that would fix the issue. I now get an error on the line Set rs = db.OpenRecordset(strQueryname) The error

I have left the previous way commented so if a solution is provided for that I can change back at any time.

Sub EmailQuery(strQueryName As String)

'On Error GoTo Err_EmailRequery_Click

'    Dim cn As ADODB.Connection
'    Dim rs As ADODB.Recordset
    Dim strEmail As String
    Dim db As DAO.Database
    Dim rs As DAO.Recordset

    Set db = CurrentDb
    Set rs = db.OpenRecordset(strQueryName)

'    Set cn = CurrentProject.Connection
'    Set rs = New ADODB.Recordset

    MsgBox strQueryName
    
'    rs.Open strQueryName, cn
    
    With rs
'    .MoveLast
'    .MoveFirst

        Do While Not .EOF
            strEmail = strEmail & .Fields("Email") & ";"
            .MoveNext
        Loop
        .Close
    End With
    
    strEmail = Left(strEmail, Len(strEmail) - 1)
    
    DoCmd.SendObject , , , , , strEmail, , , True, False
    
'Exit_EmailRequery_Click:
'
'    Exit Sub
'
'Err_EmailRequery_Click:
'
'    MsgBox Err.Description
'
'    Resume Exit_EmailRequery_Click

End Sub

Edit 2

Current code in main function

Sub EmailQuery(strQueryName As String)

'On Error GoTo Err_EmailQuery_Click

    Dim strEmail As String
    Dim db As DAO.Database
    Dim rs As DAO.Recordset

    Set db = CurrentDb
    Set rs = db.OpenRecordset(strQueryName)

    MsgBox strQueryName
    
    With rs
'    .MoveLast
'    .MoveFirst
        Do While Not .EOF
            strEmail = strEmail & .Fields("Email") & ";"
            .MoveNext
        Loop
        .Close
    End With
    
    strEmail = Left(strEmail, Len(strEmail) - 1)
    
    DoCmd.SendObject , , , , , strEmail, , , True, False
    
'Exit_EmailQuery_Click:
'
'    Exit Sub
'
'Err_EmailQuery_Click:
'
'    MsgBox Err.Description
'
'    Resume Exit_EmailQuery_Click

End Sub

Current SQL

PARAMETERS [PrmID] Long;
SELECT DISTINCT tblSuppliers.SupplierName, IIf( IsNull(BusinessEmail) , PersonalEmail, BusinessEmail) AS Email
FROM (tblSuppliers 
INNER JOIN tblSuppliersAgreements ON tblSuppliers.ID = tblSuppliersAgreements.SupplierID) 
INNER JOIN tblContacts ON tblSuppliers.ID = tblContacts.SupplierID
WHERE ((tblSuppliersAgreements.AgreementID)=[PrmID]);

I know there are probably issues with the way the SQL is done, being halfway parameterised or just done wrong.

Error with code in edit 2

Solution

  • Several issues with your attempts:

    • Named Objects: Calling a saved query with ADO Recordset.Open which mostly expects SQL statements or command objects and not named objects. Hence, the reason for your first error. Instead, use Conn.Execute which prepends standard SQL syntax to named objects. Alternatively explicitly pass SELECT * FROM with query objects. This is not an issue for DAO recordsets (library specifically focused on the MS Access object model whereas ADO is generalized for any backend).

    • Parameters: Using form control values in backend queries that do not see form values. Any query not run with DoCmd like OpenQuery (for select queries) or RunSQL (for action queries) does not recognize form controls. Hence, the reason for second error. Instead of Forms!MyForm!MyControl, use ADO Command parameters or DAO QueryDefs parameters. Search my [vba] tag answers for countless ADO or DAO parameters solutions. See below for your use case:

      Sub EmailQuery(strQueryName As String)
On Error GoTo Err_EmailQuery_Click
    Dim strEmail As String
    Dim db As DAO.Database
    Dim qdef As DAO.QueryDef
    Dim rs As DAO.Recordset

    Set db = CurrentDb
    Set qdef = db.QueryDefs(strQueryName)

    With qdef
        ' BIND PARAMETER
        .Parameters("PrmID") = [Forms]![frmMainMenu]![cboAgreement]
        ' OPEN RECORDSET
        Set rs = .OpenRecordset()
    End With

    '...loop and email...

Exit_EmailQuery_Click:
    rs.Close
    Set rs = Nothing: Set qdef = Nothing: Set db = Nothing
Exit Sub

Err_EmailQuery_Click:
    MsgBox Err.Number & " - " & Err.Description, vbCritical, "RUNTIME ERROR"
    Resume Exit_EmailQuery_Click
End Sub

    • Special Functions: Running only MS Access GUI methods like NZ in backend queries that do not recognize such functions. You will run into this error if you resolve above two issues. Use IIF + ISNULL/IS NULL. Similarly, VBA user-defined functions will not be recognized.