[2 days left] What’s wrong with your cloud strategy? Learn why multicloud solutions matter with Nimble Storage.Register Now

x
?
Solved

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

Posted on 2016-10-06
5
Medium Priority
?
79 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
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 3
  • 2
5 Comments
 
LVL 7

Assisted Solution

by:COACHMAN99
COACHMAN99 earned 2000 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 2000 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

On Demand Webinar: Networking for the Cloud Era

Did you know SD-WANs can improve network connectivity? Check out this webinar to learn how an SD-WAN simplified, one-click tool can help you migrate and manage data in the cloud.

Question has a verified solution.

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

By default Outlook 2016 displays only one time zone in the Calendar. The following article explains how to display two time zones in one calendar view.
Are you looking for the options available for exporting EDB files to PST? You may be confused as they are different in different Exchange versions. Here, I will discuss some options available.
CodeTwo Sync for iCloud (http://www.codetwo.com/sync-for-icloud?sts=6554) automatically synchronizes your Outlook 2016, 2013, 2010 or 2007 folders with iCloud folders available via iCloud Control Panel. This lets you automatically sync them with…
Have you created a query with information for a calendar? ... and then, abra-cadabra, the calendar is done?! I am going to show you how to make that happen. Visualize your data!  ... really see it To use the code to create a calendar from a q…
Suggested Courses

649 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