Solved

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

Posted on 2016-10-06
5
51 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

Windows Server 2016: All you need to know

Learn about Hyper-V features that increase functionality and usability of Microsoft Windows Server 2016. Also, throughout this eBook, you’ll find some basic PowerShell examples that will help you leverage the scripts in your environments!

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

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.
Is your Office 365 signature not working the way you want it to? Are signature updates taking up too much of your time? Let's run through the most common problems that an IT administrator can encounter when dealing with Office 365 email signatures.
With Microsoft Access, learn how to specify relationships between tables and set various options on the relationship. Add the tables: Create the relationship: Decide if you’re going to set referential integrity: Decide if you want cascade upda…
The viewer will learn the benefit of using external CSS files and the relationship between class and ID selectors. Create your external css file by saving it as style.css then set up your style tags: (CODE) Reference the nav tag and set your prop…

911 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

19 Experts available now in Live!

Get 1:1 Help Now