Solved

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

Posted on 2016-10-06
5
43 Views
Last Modified: 2016-10-06
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
Comment
Question by:shieldsco
  • 3
  • 2
5 Comments
 
LVL 7

Assisted Solution

by:COACHMAN99
COACHMAN99 earned 500 total points
ID: 41832190
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
 

Author Comment

by:shieldsco
ID: 41832293
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
 
LVL 7

Accepted Solution

by:
COACHMAN99 earned 500 total points
ID: 41832319
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
 

Author Comment

by:shieldsco
ID: 41832344
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
 

Author Comment

by:shieldsco
ID: 41832365
Figured it out ... Thanks
0

Featured Post

Enabling OSINT in Activity Based Intelligence

Activity based intelligence (ABI) requires access to all available sources of data. Recorded Future allows analysts to observe structured data on the open, deep, and dark web.

Join & Write a Comment

Follow this checklist to learn more about the 15 things you should never include in an email signature from personal quotes, animated gifs and out-of-date marketing content.
Following basic email etiquette rules will help you write a professional email and achieve a good, lasting impression with your contacts.
With Microsoft Access, learn how to start a database in different ways and produce different start-up actions allowing you to use a single database to perform multiple tasks. Specify a start-up form through options: Specify an Autoexec macro: Us…
Polish reports in Access so they look terrific. Take yourself to another level. Equations, Back Color, Alternate Back Color. Write easy VBA Code. Tighten space to use less pages. Launch report from a menu, considering criteria only when it is filled…

746 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

12 Experts available now in Live!

Get 1:1 Help Now