Solved

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

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

What is SQL Server and how does it work?

The purpose of this paper is to provide you background on SQL Server. It’s your self-study guide for learning fundamentals. It includes both the history of SQL and its technical basics. Concepts and definitions will form the solid foundation of your future DBA expertise.

Question has a verified solution.

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

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.
As tax season makes its return, so does the increase in cyber crime and tax refund phishing that comes with it
This Experts Exchange video Micro Tutorial shows how to tell Microsoft Office that a word is NOT spelled correctly. Microsoft Office has a built-in, main dictionary that is shared by Office apps, including Excel, Outlook, PowerPoint, and Word. When …
Access reports are powerful and flexible. Learn how to create a query and then a grouped report using the wizard. Modify the report design after the wizard is done to make it look better. There will be another video to explain how to put the final p…

773 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