Please help below code is not generating the mail and hangs access application:
Where is issue as when I dont do dQuery Processing Email Generates properly but dont include subform records aswell.
Without Subform Details Mail is something like this Email Generated with Proper variables present on MainForm
Private Sub InformCustomer_Click()
On Error GoTo Err_InformCustomer_Click
Dim CustName As String ' Customer Name
Dim varTo As Variant '-- Address for SendObject
Dim stText As String '-- E-mail text
Dim DelDate As Variant '-- Rec date for e-mail text
Dim stSubject As String '-- Subject line of e-mail
Dim stOrderID As String '-- The Order ID from form
Dim strSQL As String '-- Create SQL update statement
Dim errLoop As Error
Dim dQuery As String
Dim MyDb As DAO.Database
Dim rs As DAO.Recordset
stOrderID = Me![OdrID]
strSQL = "SELECT BrandName, ModelName, Status " _
& " FROM OrderProdDetails " _
& " WHERE (OrdID)=" & stOrderID & ";"
Set MyDb = CurrentDb
Set rs = CurrentDb.OpenRecordset(strSQL, dbOpenDynaset)
While Not rs.EOF
dQuery = dQuery & rs![BrandName].Value & vbTab & rs![ModelName].Value & rs![Status].Value & vbCrLf
Wend
Set rs = Nothing
CustName = Me![CustName]
varTo = Me![CustEmail]
stSubject = ":: Update - Oder Status ::"
stOrderID = Me![OdrID]
DelDate = Me![OdrDeliveryDate]
stText = "Dear" & CustName & Chr$(13) & _
"You have been assigned a new ticket." & Chr$(13) & Chr$(13) & _
"Order Number: " & stOrderID & Chr$(13) & _
_
"Please refer to your order status " & Chr$(13) & _
"Exp Delevery Date: " & DelDate & Chr$(13) & Chr$(13) & _
dQuery & Chr$(13) & _
"This is an automated message. Please do not respond to this e-mail."
'Write the e-mail content for sending to assignee
DoCmd.SendObject , , acFormatTXT, varTo, , , stSubject, stText, True
MsgBox "Done"
Exit Sub
Err_InformCustomer_Click:
MsgBox Err.Description
End Sub
You have created an endless loop.
While Not rs.EOF
dQuery = dQuery & rs![BrandName].Value & vbTab & rs![ModelName].Value & rs![Status].Value & vbCrLf
' This is missing -->
rs.MoveNext
Wend
Related
I tested my code with static value
Set rs = CurrentDb.OpenRecordset("SELECT mail FROM UsersData WHERE depid = 2")
and it worked, but when I use the full statement
Set rs = CurrentDb.OpenRecordset( _
"SELECT mail FROM UsersData WHERE depid IN (SELECT depid FROM CyclesDefinitions WHERE cycledefid = " _
& Me.Combo135.Value & " AND rank = " & Me.Combo202.Value) & ")"
it generates an error i don't know what it means
(Compile Error: Type mismatch) and then nothing happens.
full code below: (everything works as intended and tested, but this line)
Private Sub Command15_Click()
Dim dbs As Database
Dim qdf As QueryDef
Set dbs = CurrentDb
Dim StrSqls As String
Dim rs As DAO.Recordset
Set rs = CurrentDb.OpenRecordset("SELECT mail FROM UsersData WHERE depid IN (SELECT depid FROM CyclesDefinitions WHERE cycledefid = " & Me.Combo135.Value & " AND rank = " & Me.Combo202.Value) & ")"
'Set rs = CurrentDb.OpenRecordset("SELECT mail FROM UsersData WHERE depid = 2")
Dim ToMails As String
'Check is a flag on form to make sure record is not inserted more than once in Cycles Table
If Me.Check137.Value = False Then
DoCmd.RunCommand acCmdSaveRecord
dbs.Execute "INSERT INTO Cycles (scinvid, cycledefid) VALUES (" & Me.Combo200.Value & ", " & Me.Combo135.Value & ");"
dbs.Close
Me.Check137.Value = True
If Not (rs.EOF And rs.BOF) Then
rs.MoveFirst 'Unnecessary in this case, but still a good habit
Do Until rs.EOF = True
ToMails = rs(0) & ";" & ToMails
rs.MoveNext
Loop
Else
MsgBox "There are no Emails recorded for such department"
End If
rs.Close 'Close the recordset
Debug.Print ToMails
Set rs = Nothing 'Clean up
DoCmd.SendObject acSendNoObject, , , ToMails, , , "Test Subject", "Test Message", True
'objRecordset.Open ("SELECT depid FROM CyclesDefinitions WHERE cycledefid =" & Me.Combo135.Value & " AND cycleranktracking =" & Me.Combo202.Value)
'UserDepartmentID = DLookup("depid", "UsersData", "[username]= '" & fOSUserName & "'")
DoCmd.GoToRecord , , acNewRec
Me.Combo83.Requery
Combo83.RowSource = "SCINVSearch"
ElseIf Me.Check137.Value = True Then
DoCmd.GoToRecord , , acNewRec
Me.Combo83.Requery
Combo83.RowSource = "SCINVSearch"
End If
End Sub
In
Set rs = CurrentDb.OpenRecordset( _
"SELECT mail FROM UsersData WHERE depid IN (SELECT depid FROM CyclesDefinitions WHERE cycledefid = " _
& Me.Combo135.Value & " AND rank = " & Me.Combo202.Value) & ")"
You have placed the closing brace at the wrong place. It should be
Set rs = CurrentDb.OpenRecordset( _
"SELECT mail FROM UsersData WHERE depid IN (SELECT depid FROM CyclesDefinitions WHERE cycledefid = " _
& Me.Combo135.Value & " AND rank = " & Me.Combo202.Value & ")")
Your version tries to append a ")" to the Recordset instead of the SQL string. This generates the Type mismatch error.
I have a vba that can send out multiple emails to vendors, but I would like to change it so it embeds the query and only sends one email per vendor. Here is what I have so far:
Option Compare Database
Public Sub SendFollowUpEmail()
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim emailTo As String
Dim emailSubject As String
Dim emailText As String
Dim outApp As Outlook.Application
Dim outMail As Outlook.MailItem
Dim outlookStarted As Boolean
On Error Resume Next
Set outApp = GetObject(, "Outlook.Application")
On Error GoTo 0
If outApp Is Nothing Then
Set outApp = CreateObject("Outlook.Application")
outlookStarted = True
End If
Set db = CurrentDb
strSQL = "SELECT qry002UnmatchedOpenInvoices.kyUnique, qry002UnmatchedOpenInvoices.[Vendor Nbr],qry002UnmatchedOpenInvoices.[Vendor Name], " & _
" qry002UnmatchedOpenInvoices.[Purchasing Document], qry002UnmatchedOpenInvoices.Item,qry002UnmatchedOpenInvoices.[Document Date], " & _
" qry002UnmatchedOpenInvoices.Material, qry002UnmatchedOpenInvoices.[Short Text],qry002UnmatchedOpenInvoices.[Material Group], " & _
" qry002UnmatchedOpenInvoices.[Invoice Sent], qry002UnmatchedOpenInvoices.[Order Quantity],qry002UnmatchedOpenInvoices.[Order Unit], " & _
" qry002UnmatchedOpenInvoices.[Quantity in SKU], qry002UnmatchedOpenInvoices.[Stockkeeping unit],qry002UnmatchedOpenInvoices.[Net price], " & _
" qry002UnmatchedOpenInvoices.Currency, qry002UnmatchedOpenInvoices.[Price Unit],qry002UnmatchedOpenInvoices.[Release status], " & _
" qry002UnmatchedOpenInvoices.[No of Positions], tblVendors.Vendor, tblVendors.Email " & _
" FROM qry002UnmatchedOpenInvoices LEFT JOIN tblVendors ON qry002UnmatchedOpenInvoices.[Vendor Nbr] =tblVendors.[Vendor Number] " & _
" WHERE (((qry002UnmatchedOpenInvoices.Material) Is Null) AND ((qry002UnmatchedOpenInvoices.[Invoice Sent]) Is Null));"
Set rs = db.OpenRecordset(strSQL, dbOpenDynaset)
Do Until rs.EOF
emailTo = Trim(rs.Fields("Email").Value & "; tom.nguyen#flocorp.com;mike.huston#flocorp.com")
emailSubject = "Open Invoices"
emailText = Trim("Please send invoices of the below Purchase Orders:") & vbCrLf
emailText = emailText & _
"PO# " & rs.Fields("[Purchasing Document]").Value
Set outMail = outApp.CreateItem(olMailItem)
outMail.To = emailTo
outMail.Subject = emailSubject
outMail.Body = emailText
outMail.Send
'rs.Edit
'rs("FUP_Date_Sent") = Now()
rs.MoveNext
Loop
rs.Close
Set rs = Nothing
Set db = Nothing
If outlookStarted Then
outApp.Quit
End If
Set outMail = Nothing
Set outApp = Nothing
End Sub
What you need to do is to use two recordsets. The first selects the distinct vendors, and the second selects the invoices for that vendor. Something like:
Sub sSendFollowUpEMail()
On Error GoTo E_Handle
Dim db As DAO.Database
Dim rsVendor As DAO.Recordset
Dim rsInvoice As DAO.Recordset
Dim objOL As New Outlook.Application
Dim objMail As Outlook.MailItem
Dim strSQL As String
Dim emailTo As String
Dim emailText As String
Set db = CurrentDb
strSQL = "SELECT DISTINCT V.[Vendor Number], V.EMail " _
& " FROM qry002UnmatchedOpenInvoices AS I LEFT JOIN tblVendors AS V ON I.[Vendor Nbr]=V.[Vendor Number] " _
& " WHERE I.Material IS NULL " _
& " AND I.[Invoice Sent] IS NULL;"
Set rsVendor = db.OpenRecordset(strSQL)
If Not (rsVendor.BOF And rsVendor.EOF) Then
Do
strSQL = "SELECT I.[Purchasing Document] " _
& " FROM qry2002UnMatchedOpenInvoices AS I " _
& " WHERE I.Material IS NULL " _
& " AND I.[Invoice Sent] IS NULL " _
& " AND I.[Vendor Nbr]=" & rsVendor("Vendor Number") _
& " ORDER BY I.[Purchasing Document] ASC;"
Set rsInvoice = db.OpenRecordset(strSQL)
If Not (rsInvoice.BOF And rsInvoice.EOF) Then
emailText = "Please pay:"
Do
emailText = emailText & vbCrLf & rsInvoice("Purchasing Document")
rsInvoice.MoveNext
Loop Until rsInvoice.EOF
End If
emailTo = rsVendor!EMail
Set objMail = objOL.CreateItem(olMailItem)
objMail.To = emailTo
objMail.Subject = EmailSubject
objMail.Body = emailText
objMail.Send
rsVendor.MoveNext
Loop Until rsVendor.EOF
End If
sExit:
On Error Resume Next
rsVendor.Close
rsInvoice.Close
Set rsVendor = Nothing
Set rsInvoice = Nothing
Set db = Nothing
Set objMail = Nothing
objOL.Quit
Set objOL = Nothing
Exit Sub
E_Handle:
MsgBox Err.Description & vbCrLf & vbcrfl & "sSendFollowUpEMail", vbOKOnly + vbCritical, "Error: " & Err.Number
Resume sExit
End Sub
A few notes.
In your original recordset you were including a whole load of fields that were not used in this procedure, which is not recommended - only get data that you need as this will enhance performance;
Secondly, it appears that you are mixing early and late binding of Outlook;
Finally, I've used aliases for the query/table names in the SQL statements - this makes the SQL more manageable, and also if you need to change one of the original tables/queries it is a lot easier to change the name just once.
Regards,
I have three listboxes and a date range on a parameter form. I am able to pass all of the Listbox selections with no problem. I cannot seem to find a way or answer to adding a date range to the where clause.
The Date field is Course_Date, and the textbox control names for the dates are Start_Date and End_Date
Option Compare Database
Option Explicit
Private Sub cmdPreviewReports_Click()
On Error GoTo cmdPreviewReports_Err
Dim blnQueryExists As Boolean
Dim cat As New ADOX.Catalog
Dim cmd As New ADODB.Command
Dim qry As ADOX.View
Dim varItem As Variant
Dim strInstructors As String
Dim strCourseType As String
Dim strCourseTypeCondition As String
Dim strRoleType As String
Dim strRoleTypeCondition As String
Dim strCourse_Date As Date
Dim strDateRange As String
Dim strSql As String
' Check for the existence of the stored query
blnQueryExists = False
Set cat.ActiveConnection = CurrentProject.Connection
For Each qry In cat.Views
If qry.Name = "q_Parameter_Form" Then
blnQueryExists = True
Exit For
End If
Next qry
' Create the query if it does not already exist
If blnQueryExists = False Then
cmd.CommandText = "SELECT * FROM q_jt_MCR_Instructor_Roles"
cat.Views.Append "q_Parameter_Form", cmd
End If
Application.RefreshDatabaseWindow
' Turn off screen updating
DoCmd.Echo False
' Close the query if it is already open
If SysCmd(acSysCmdGetObjectState, acQuery, "q_Parameter_Form") = acObjStateOpen Then
DoCmd.Close acQuery, "q_Parameter_Form"
End If
' Build criteria string for Instructors
For Each varItem In Me.lst_Instructors.ItemsSelected
strInstructors = strInstructors & "," & Me.lst_Instructors.ItemData(varItem) & ""
Next varItem
If Len(strInstructors) = 0 Then
strInstructors = "Like '*'"
Else
strInstructors = Right(strInstructors, Len(strInstructors) - 1)
strInstructors = "IN(" & strInstructors & ")"
End If
' Build criteria string for CourseType
For Each varItem In Me.lst_Course_Type.ItemsSelected
strCourseType = strCourseType & "," & Me.lst_Course_Type.ItemData(varItem) & ""
Next varItem
If Len(strCourseType) = 0 Then
strCourseType = "Like '*'"
Else
strCourseType = Right(strCourseType, Len(strCourseType) - 1)
strCourseType = "IN(" & strCourseType & ")"
End If
' Get CourseType condition
If Me.optAndCourseType.Value = True Then
strCourseTypeCondition = " AND "
Else
strCourseTypeCondition = " OR "
End If
' Build criteria string for RoleType
For Each varItem In Me.lst_Role.ItemsSelected
strRoleType = strRoleType & "," & Me.lst_Role.ItemData(varItem) & ""
Next varItem
If Len(strRoleType) = 0 Then
strRoleType = "Like '*'"
Else
strRoleType = Right(strRoleType, Len(strRoleType) - 1)
strRoleType = "IN(" & strRoleType & ")"
End If
' Get RoleType condition
If Me.optAndRoleType.Value = True Then
strRoleTypeCondition = " AND "
Else
strRoleTypeCondition = " OR "
End If
'Build Criteria String for Course_Date
strDateRange = strSql And " Between Me.[Start_Date] AND Me.[End_Date]"
' Build SQL statement
strSql = "SELECT q_jt_MCR_Instructor_Roles.* FROM q_jt_MCR_Instructor_Roles " & _
"WHERE q_jt_MCR_Instructor_Roles.[InstructorID] " & strInstructors & _
strCourseTypeCondition & "q_jt_MCR_Instructor_Roles.[Course_TypesID] " & strCourseType & _
strRoleTypeCondition & "q_jt_MCR_Instructor_Roles.[Roles_ID] " & strRoleType & ";"
' Apply the SQL statement to the stored query
cat.ActiveConnection = CurrentProject.Connection
Set cmd = cat.Views("q_Parameter_Form").Command
cmd.CommandText = strSql
Set cat.Views("q_Parameter_Form").Command = cmd
Set cat = Nothing
' Open the Query
If Not IsNull(cboReports) And cboReports <> "" Then
DoCmd.OpenReport cboReports, acViewPreview ' use acNormal to print without preview
Else
MsgBox ("Please make a Label selection first from the dropdown list to the left.")
cboReports.SetFocus
End If
cboReports = ""
' If required the dialog can be closed at this point
' DoCmd.Close acForm, Me.Name
'Restore screen updating
cmdPreviewReports_Exit:
DoCmd.Echo True
Exit Sub
cmdPreviewReports_Err:
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description:" & Err.Description _
, vbCritical, "Error"
Resume cmdPreviewReports_Exit
End Sub
I am also able to provide the database to look at if you wish?
Thank you for helping !!!!!!
William
It could be:
'Build Criteria String for Course_Date.
strDateRange = " And Course_Date Between #" & Format(Me![Start_Date].Value, "yyyy\/mm\/dd") & "# AND #" & Format(Me![End_Date].Value, "yyyy\/mm\/dd") & "#"
strSql = strSql & strDateRange
My form takes the data the user entered, constructs a SQL statement and returns the results. I would like to have a message box pop up when there are no matches found.
My current code/idea:
If qdf.sql = 0 Then
MsgBox "No clients matching your information." & _
vbCrLf & "have been found. Please try again." & _
, vbCritical, "No Matches"
Else
DoCmd.OpenForm "frmSearchResults"
Me.Visible = False
End If
I'm having trouble figuring out the correct syntax for if qdf.sql = 0 .
UPDATE: Full query
Private Sub cmdSearch_Click()
'On Error GoTo cmdSearch_Click_err
Dim db As Database
Dim strSQL As String
Dim rs As DAO.Recordset
Dim qdf As QueryDef
Dim strClientID As String
Dim strLastName As String
Dim strFirstName As String
Dim strDOB As String
Set db = CurrentDb
Set rs = db.OpenRecordset(qdf.sql)
' call QueryCheck module to determine if query exists
If Not QueryExists("qrySearch") Then
Set qdf = db.CreateQueryDef("qrySearch")
Else
Set qdf = db.QueryDefs("qrySearch")
End If
' handle nulls in the user's entries
If IsNull(Me.txtClientID.Value) Then
strClientID = " Like '*' "
Else
strClientID = "='" & Me.txtClientID.Value & "' "
End If
If IsNull(Me.txtLastName.Value) Then
strLastName = " Like '*' "
Else
strLastName = " Like '" & Me.txtLastName.Value & "*' "
End If
If IsNull(Me.txtFirstName.Value) Then
strFirstName = " Like '*' "
Else
strFirstName = " Like '*" & Me.txtFirstName.Value & "*' "
End If
If IsNull(Me.txtDOB.Value) Then
strDOB = " Like '*' "
Else
strDOB = "='" & Me.txtDOB.Value & "' "
End If
strSQL = "SELECT Clients.* " & _
"FROM Clients " & _
"WHERE Clients.clientid" & strClientID & _
"AND Clients.namelast" & strLastName & _
"AND Clients.namefirst" & strFirstName & _
"AND Clients.birthdate" & strDOB & _
"ORDER BY Clients.namelast,Clients.namefirst;"
Debug.Print strSQL
' check to see if the results form is open and close if it is
DoCmd.Echo False
If Application.SysCmd(acSysCmdGetObjectState, acForm, "frmSearchResults") = acObjStateOpen Then
DoCmd.Close acForm, "frmSearchResults"
End If
' run SQL statment
qdf.sql = strSQL
' check for no matches found
If rs.RecordCount = 0 Then
MsgBox "No clients matching your information were found." & _
vbCrLf & "Please search again.", vbInformation, "No Matches"
Else
DoCmd.OpenForm "frmSearchResults"
Me.Visible = False
End If
'cmdSearch_Click_exit:
' DoCmd.Echo True
' Set qdf = Nothing
' Set db = Nothing
'Exit Sub
'cmdSearch_Click_err:
' MsgBox "An unexpected error has occurred." & _
' vbCrLf & "Please note of the following details and contact the EIIS support desk:" & _
' vbCrLf & "Error Number: " & Err.Number & _
' vbCrLf & "Description: " & Err.Description _
' , vbCritical, "Error"
' Resume cmdSearch_Click_exit
End Sub
The reason that If qdf.sql = 0 then won't perform a proper check is that qdf contains the information about your query such as the SQL text that you are checking in that statement but not the results.
To get the results of the query you need to assign it to a Recordset after you have build your query. So first build your query and then assign it to the record set.
Dim db as DAO.Database
Set db = CurrentDb
Dim qdf as DAO.Querydef
Set qdf = db.CreateQueryDef("qrySearch")
Dim rs as DAO.Recordset
Set rs = CurrentDb.OpenRecordset(qdf.sql)
You can then check what your record set has returned.
If rs.RecordCount = 0 then
So where you have your line ' run SQL statment you would want to place the Set rs line.
If you have any ADO experience you can use something like
dim strSQL as String
dim conn as Connection
dim cmd as Command
dim rs as Recordset
(set up connection/command here)
cmd.commandtext = (your select query)
set rs = Command.execute
if rs.eof then
(or if rs.recordcount = 0 however returning a recordcount requires the correct cursortype - usually adOpenStatic - to be used)
'msgbox no match
else
'do stuff
If any of this is alien, then post your actual query and I'll try and give you the code in full. Good luck!
I have a suppliers' report about 150 pages in access 2007. Each report has address, emails contact person, phone number, products and name of company per page. Once a month I have to send an email to the suppliers to confirm changes of contact person address, phone number and products.
I want to send that particular report to that particular email not the whole report.
I want this to be automated.
I have written code in VBA after research on the net and still not working. I am getting Too many parameters. Expected 1. Error.
Below is code for my form with a Send Report button.
Dim strSql As String
Dim strSubject As String
Dim strMsgBody As String
strSql = "SELECT DISTINCT Name, EMail FROM [Suppliers and Products]"
Set dbs = CurrentDb
Set rst = dbs.OpenRecordset(strSql)
'loop through the recordset
Do While Not rst.EOF
' grab email string
strEmail = rst.Fields("EMail")
' grab name
strName = rst.Fields("Name")
Call fnUserID(rst.Fields("EMail"))
'send the pdf of the report to curent supplier
On Error Resume Next
strSubject = "September 2012 Supplier's Listing"
strMsgBody = "2008 Procedure Review Attached"
DoCmd.SendObject acSendReport, "Suppliers Confirmation forms", acFormatHTML, strEmail, , , strSubject, strMsgBody, False
If Err.Number <> 0 Then
MsgBox Err.Number & vbCrLf & Err.Description, vbOKOnly, "Delivery Failure to the following email address: " & strEmail
End If
On Error GoTo PROC_ERR
' move and loop
rst.MoveNext
Loop
' clean up
rst.Close
Set rst = Nothing
dbs.Close
Set dbs = Nothing
PROC_Exit:
Exit Sub
PROC_ERR:
MsgBox Err.Description
Resume PROC_Exit
I have a module with the following code
Option Compare Database
Public Function fnUserID(Optional Somevalue As Variant = Null, Optional reset As Boolean = False) As Variant
Static EMail As Variant
If reset Or IsEmpty(EMail) Then EMail = Null
If Not IsNull(Somevalue) Then EMail = Somevalue
fnUserID = EMail
End Function
Public Function SendReportByEmail(strReportName As String, strEmail As String)
On Error GoTo PROC_ERR
Dim strRecipient As String
Dim strSubject As String
Dim strMessageBody As String
'set the email variables
strRecipients = strEmail
strSubject = Reports(strReportName).Caption
strMessageBody = "May 2012 Suppliers' List "
' send report as HTML
DoCmd.SendObjectac acSendReport, strReportName, acFormatHTML, strRecipients, , , strSubject, strMessageBody, False
SendReportByEmail = True
PROC_Exit:
Exit Function
Proc Err:
SendReportByEmail = False
If Err.Number = 2501 Then
Call MsgBox("The email was not sent for " & strEmail & ".", vbOKOnly + vbExclamation + vbDefaultButton1, "User Cancelled Operation")
Else: MsgBox Err.Description
End If
Resume PROC_Exit
End Function
The query which is report is getting its data has the following SQL.
SELECT Names.Name, Names.Phys_Address,
Names.Telephones, Names.Fax, Names.EMail,
Names.Web, Names.Caption AS Expr1, [Products by Category].CatName,
[Products by Category].ProdName
FROM [Names]
INNER JOIN [Products by Category]
ON Names.SuppID=[Products by Category].SupID
WHERE ((Names.EMail = fnUserID()) or (fnUserID() Is Null));
Please help as I am stuck to where I am going wrong.
Some notes.
On Error GoTo PROC_ERR
Dim qdf As QueryDef
Dim strSQL As String
Dim strSubject As String
Dim strMsgBody As String
strSQL = "SELECT DISTINCT [Name], EMail, SuppID FROM Names " _
& "INNER JOIN [Products by Category] " _
& "ON Names.SuppID=[Products by Category].SupID "
Set dbs = CurrentDb
Set rst = dbs.OpenRecordset(strSql)
qrySQL = "SELECT Names.Name, Names.Phys_Address, " _
& "Names.Telephones, Names.Fax, Names.EMail, " _
& "Names.Web, Names.Caption AS Expr1, " _
& "[Products by Category].CatName, " _
& "[Products by Category].ProdName " _
& "FROM [Names] " _
& "INNER JOIN [Products by Category] " _
& "ON Names.SuppID=[Products by Category].SupID "
'loop through the recordset
Do While Not rst.EOF
' grab email string
strEmail = rst.Fields("EMail")
' grab name
strName = rst.Fields("Name")
' You should check that the email is not null
Call fnUserID(rst.Fields("EMail"))
'send the pdf of the report to curent supplier
'On Error Resume Next
'The query that the report uses
Set qdf = CurrentDB.QueryDefs("Suppliers and Products")
qdf.SQL = qrySQL & " WHERE SuppID=" & rst!SuppID
strSubject = "September 2012 Supplier's Listing"
strMsgBody = "2008 Procedure Review Attached"
DoCmd.SendObject acSendReport, "Suppliers Confirmation forms", _
acFormatHTML, strEmail, , , strSubject, strMsgBody, False
' move and loop
rst.MoveNext
Loop
''Reset the query
qdf.SQL = qrySQL
rst.Close
Set rst = Nothing
dbs.Close
Set dbs = Nothing
PROC_Exit:
Exit Sub
PROC_ERR:
If Err.Number <> 0 Then
MsgBox Err.Number & vbCrLf & Err.Description, vbOKOnly, _
"Delivery Failure to the following email address: " & strEmail
End If
MsgBox Err.Description
Resume PROC_Exit