• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 84
  • Last Modified:

Send Email From Access 2010 to Outlook 2010 with two tables embeded

I'm using the code below trying to send two Access tables to Outlook email. The first table works ok but I get an error 3021 on the second:
Error

Dim sSubj As String, sBody As String, sTo As String, strCC As String
Dim sBody1 As String
Dim rst As DAO.Recordset
Dim rs As DAO.Recordset
Dim strFname As String

'Get Active Users
Set rst = CurrentDb.OpenRecordset("SELECT tblUserMaster.OpDiv, tblUserMaster.Fname, tblUserMaster.Lname, tblUserMaster.Level, tblUserMaster.Approver, tblUserMaster.ApproverFname FROM tblUserMaster WHERE (((tblUserMaster.Active) = Yes))GROUP BY tblUserMaster.OpDiv, tblUserMaster.Fname, tblUserMaster.Lname, tblUserMaster.Level, tblUserMaster.Approver, tblUserMaster.ApproverFname HAVING (((tblUserMaster.OpDiv)='CDC'))")
strName = rst![ApproverFname]



Set rst1 = CurrentDb.OpenRecordset("SELECT tblQuarter.Quarter FROM tblQuarter")
strQuarter = rst1![Quarter]


Set rst2 = CurrentDb.OpenRecordset("SELECT tblEmailRoles.OpDiv, tblEmailRoles.Role, tblEmailRoles.Level FROM tblEmailRoles WHERE (((tblEmailRoles.OpDiv)='CDC'))")



'Get Email Address
Set rs = CurrentDb.OpenRecordset("tblCDCEmail")

Do Until rs.EOF
     sMail = sMail & ";" & rs("email")
    rs.MoveNext
Loop

sMail = Mid(sMail, 2)


Set objOutlook = CreateObject("Outlook.Application")
Set objEmailMessage = objOutlook.CreateItem(0)

With objEmailMessage
         .To = sMail
         If strCC & "" <> "" Then
                    .CC = strCC
         End If
         .Subject = sSubj
      
 'Email table 1
 Do Until rst.EOF
   sBody = sBody & "</tr><td>" & rst("Fname") & "</td><td>" & rst("Lname") & "</td><td>" & rst("Level") & "</td></tr>"
   rst.MoveNext
   
   'Email table 2
   sBody1 = sBody1 & "</tr><td>" & rst2("OpDiv") & "</td><td>" & rst2("Role") & "</td><td>" & rst2("Level") & "</td></tr>"
   rst2.MoveNext
 
 Loop
     

'Set body format to HTML
.BodyFormat = olFormatHTML
.CC = "FESMCustomerService@hhs.gov"
.Subject = "CFRS " & strQuarter & " Quarter User Certification"
      
sBody = "Hi " & strName & ",<br>In anticipation of CFRS <b>" & strQuarter & " Quarter</b> User Certification, would you please review the CDC users listed below and confirm that they are current and correct? Should access changes be necessary, please provide the CFRS User Access Request form. " & _
"<br><br><table><br>" & sBody & " </table><br><b><i><br>Thank You, <br><br>FESM Customer Service </i></div></body></html>"


 .HTMLBody = sBody
      
      .Display
      '      .send
      
     'Open Outlook
'SendKeys ("%{TAB}")
DoCmd.RunCommand acCmdAppMinimize

End With

Open in new window

0
shieldsco
Asked:
shieldsco
  • 3
  • 2
2 Solutions
 
COACHMAN99Commented:
it looks as if one of the recordsets has less records than the other?
if not.
assuming there is data (i.e. if not rst2.eof) in rst2, try a movefirst on rst2 prior to using it

for each rst do the following

if not rst1/2.eof then
    send
   movenext
end if
0
 
shieldscoAuthor Commented:
same error message on line

 
 sBody1 = sBody1 & "</tr><td>" & rst2("OpDiv") & "</td><td>" & rst2("Role") & "</td><td>" & rst2("Level") & "</td></tr>"

Open in new window

0
 
COACHMAN99Commented:
If you attempt to access data after the end of the recordset you will get this error.
Did you implement the code I suggested?
0
 
shieldscoAuthor Commented:
I fixed the 3021 error and everything complies however the second table does not display in the email message. Here is the code:


Dim sSubj As String, sBody As String, sTo As String, strCC As String
Dim sBody1 As String
Dim rst As DAO.Recordset
Dim rs As DAO.Recordset
Dim strFname As String

'Get Active Users
Set rst = CurrentDb.OpenRecordset("SELECT tblUserMaster.OpDiv, tblUserMaster.Fname, tblUserMaster.Lname, tblUserMaster.Level, tblUserMaster.Approver, tblUserMaster.ApproverFname FROM tblUserMaster WHERE (((tblUserMaster.Active) = Yes))GROUP BY tblUserMaster.OpDiv, tblUserMaster.Fname, tblUserMaster.Lname, tblUserMaster.Level, tblUserMaster.Approver, tblUserMaster.ApproverFname HAVING (((tblUserMaster.OpDiv)='CDC'))")
strName = rst![ApproverFname]



Set rst1 = CurrentDb.OpenRecordset("SELECT tblQuarter.Quarter FROM tblQuarter")
strQuarter = rst1![Quarter]


Set rst2 = CurrentDb.OpenRecordset("SELECT tblEmailRoles.OpDiv, tblEmailRoles.Role, tblEmailRoles.Level FROM tblEmailRoles WHERE (((tblEmailRoles.OpDiv)='CDC'))")



'Get Email Address
Set rs = CurrentDb.OpenRecordset("tblCDCEmail")

Do Until rs.EOF
     sMail = sMail & ";" & rs("email")
    rs.MoveNext
Loop

sMail = Mid(sMail, 2)


Set objOutlook = CreateObject("Outlook.Application")
Set objEmailMessage = objOutlook.CreateItem(0)

With objEmailMessage
         .To = sMail
         If strCC & "" <> "" Then
                    .CC = strCC
         End If
         .Subject = sSubj
      
 'Email table 1
 Do Until rst.EOF
   
   sBody = sBody & "</tr><td>" & rst("Fname") & "</td><td>" & rst("Lname") & "</td><td>" & rst("Level") & "</td></tr>"
   rst.MoveNext
   Loop
   
    
   
   'Email table 2
    Do Until rst2.EOF
    
   sBody1 = sBody1 & "</tr><td>" & rst2("OpDiv") & "</td><td>" & rst2("Role") & "</td><td>" & rst2("Level") & "</td></tr>"
   rst2.MoveNext
   
    Loop
     

'Set body format to HTML
.BodyFormat = olFormatHTML
.CC = "FESMCustomerService@hhs.gov"
.Subject = "CFRS " & strQuarter & " Quarter User Certification"
      
sBody = "Hi " & strName & ",<br>In anticipation of CFRS <b>" & strQuarter & " Quarter</b> User Certification, would you please review the CDC users listed below and confirm that they are current and correct? Should access changes be necessary, please provide the CFRS User Access Request form. " & _
"<br><table>" & sBody & " </table><br><table><br>" & sBody1 & " </table><b><i><br>Thank You, <br><br>FESM Customer Service </i></div></body></html>"




 


 .HTMLBody = sBody
 
 
 
      
      .Display
      '      .send
      
     'Open Outlook
'SendKeys ("%{TAB}")
DoCmd.RunCommand acCmdAppMinimize
End With

Open in new window

0
 
shieldscoAuthor Commented:
Figured it out ... Thanks
0

Featured Post

Industry Leaders: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

  • 3
  • 2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now