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

Sending HTML formatted email via Outlook from Access

I using the code below to send emails to Outlook from Access. In the sbody section after "Hi" I would like to insert a name from a field in a table. Thanks


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

'Get Active Users
Set rst = CurrentDb.OpenRecordset("SELECT tblUserMaster.OpDiv, tblUserMaster.Fname, tblUserMaster.Lname, tblUserMaster.Level, tblUserMaster.Approver FROM tblUserMaster WHERE (((tblUserMaster.Active) = Yes) And ((tblUserMaster.OpDiv) = 'CDC')) GROUP BY tblUserMaster.OpDiv, tblUserMaster.Fname, tblUserMaster.Lname, tblUserMaster.Level, tblUserMaster.Approver")


'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
      
      
 Do Until rst.EOF
   sBody = sBody & "</tr><td>" & rst("Fname") & "</td><td>" & rst("Lname") & "</td><td>" & rst("Level") & "</td></tr>"
   rst.MoveNext
 Loop
     

'Set body format to HTML
'.BodyFormat = olFormatHTML
.CC = "FESMCustomerService@hhs.gov"
.Subject = "CFRS User Certification"
      
sBody = "Hi,<br>In anticipation of CFRS Quarterly 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>Alfonso N. Giansanti II<br>Contractor to: ASFR Office of Finance Systems Policy & Oversight<br>U.S. Department of Health and Human Services<br><br>Deloitte Consulting LLP <br>Mobile: 860-908-8381 | FAX: 877-570-8542 | alfonso.giansanti@hhs.gov<br><br><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
  • 2
  • 2
1 Solution
 
Helen FeddemaCommented:
Save the name to a string variable, and include it in the line of HTML code; here is an example of creating an HTML email message (see the Create Line of Body Text section):

Public Sub CreateEmails()
'Created by Helen Feddema 31-Jan-2010
'Last modified by Helen Feddema 7-Feb-2010

On Error GoTo ErrorHandler

   Dim appOutlook As New Outlook.Application
   Dim dtePickup As Date
   Dim dteSold As Date
   Dim msg As Outlook.MailItem
   Dim rstAll As DAO.Recordset
   Dim rstSingle As DAO.Recordset
   Dim strBody As String
   Dim strCompany As String
   Dim strEMail As String
   Dim strFCFNumber As String
   Dim strGrade1 As String
   Dim strGrade2 As String
   Dim strHeader As String
   Dim strHTMLBody As String
   Dim strLine1 As String
   Dim strLine2 As String
   Dim strNotes As String
   Dim strQueryAll As String
   Dim strQuerySingle As String
   Dim strSignature As String
   Dim strSubject As String
   
   Set dbs = CurrentDb
   strQueryAll = "qrySendEmails"
   Set rstAll = dbs.OpenRecordset(strQueryAll)
   strQuerySingle = "qryTempEmail"
   strSignature = "</table><br><br><font face='Book Antiqua', size=5>" _
      & "<align='left'><u>John Doe</u></font><br>" _
      & "<font face='Arial', size=3><br>" _
      & "VP of Sales and Marketing<br>" _
      & "JD Inc.<br>" _
      & "Ph: 555-112-9601<br>" _
      & "Fx: 555-112-9422<br>"
   Debug.Print "Signature: " & strSignature
   
   Do While Not rstAll.EOF
      'Create filtered recordset for this customer
      lngSupplierID = Nz(rstAll![CustomerID])
      
      If lngSupplierID <> 0 Then
         strSQL = "SELECT * FROM " & strQueryAll & " WHERE " _
            & "[CustomerID] = " & lngSupplierID & ";"
      End If
   
      Debug.Print "SQL for " & strQuerySingle & ": " & strSQL
      lngCount = CreateAndTestQuery(strQuerySingle, strSQL)
      Debug.Print "No. of items found: " & lngCount
      If lngCount = 0 Then
         strPrompt = "No records found; canceling"
         strTitle = "Canceling"
         MsgBox strPrompt, vbOKOnly + vbCritical, strTitle
         GoTo ErrorHandlerExit
      Else
         'Create starter HTML text for this customer
         strHTMLBody = ""
         strHeader = "<p><img border='0' src='Image.jpg' " _
	    	& "width='559' height='120'></p> & "<font face='Arial', size=3>" _
            & "Please schedule the following: <br><br>" _
            & "<table width='791' border='1'>" _
            & "   <tr>" _
            & "      <td width='283'height='26' nowrap valign='bottom'" _
            & "align='left'><font face='Arial', size=3><strong>Grade</strong></font></td>" _
            & "      <td width='127' height='26'nowrap valign='bottom'" _
            & "align='left'><font face='Arial', size=3><strong>FCF Pickup #</strong></font>" _
            & "      <td width='144'height='26' nowrap valign='bottom'" _
            & "align='left'><font face='Arial', size=3><strong>Pickup Date</strong></font></td>" _
            & "      <td width='237'height='26' nowrap valign='bottom'" _
            & "align='left'><font face='Arial', size=3><strong>Notes</strong></font></td>" _
            & "   </tr>"

         Set rstSingle = dbs.OpenRecordset(strQuerySingle)
         strEMail = Nz(rstSingle![EmailAddress])
         strCompany = Nz(rstSingle![strCompany])
         strSubject = "Loads for " & strCompany
         
         'Create email for this customer
         Set msg = appOutlook.CreateItem(olMailItem)
         msg.To = strEMail
         msg.Subject = strSubject
         msg.BodyFormat = olFormatHTML
         
         'Process loads per customer
         Debug.Print "Processing load(s) for " & strCompany
         strBody = ""
         
         Do While Not rstSingle.EOF
            strLine1 = ""
            strLine2 = ""
            strGrade1 = ""
            strGrade2 = ""
            strSlipNo = Nz(rstSingle![SlipNo])
            dteSold = Nz(rstSingle![DateSold])
            dtePickup = Nz(rstSingle![ScheduledPickup])
            strFCFNumber = Nz(rstSingle![FCFNumber])
            strGrade1 = Nz(rstSingle![Grade1])
            Debug.Print "Grade 1: " & strGrade1
            strGrade2 = Nz(rstSingle![Grade2])
            Debug.Print "Grade 2: " & strGrade2
            strNotes = Nz(rstSingle![Notes])
            
            'Create line of body text
            strLine1 = "<font face='Arial', size=3" _
               & "   <tr>" _
               & "      <td width='283'valign='bottom' align='left'>" & strGrade1 & "</td>" _
               & "      <td width='127' valign='bottom' align='left'>" & strFCFNumber _
               & "      <td width='144'valign='bottom' align='left'>" _
               & Format(dtePickup, "m/d/yyyy") & "</td>" _
               & "      <td width='237'valign='bottom' align='left'>" & strNotes & "</td>" _
               & "   </tr></font>"
            Debug.Print "Line 1: " & strLine1
            
            If strGrade2 <> "" Then
               strLine2 = "<font face='Arial', size=3>" _
                  & "   <tr>" _
                  & "      <td width='283'valign='bottom' align='left'>" & strGrade2 & "</td>" _
                  & "      <td width='127' valign='bottom' align='left'>" & strFJDNumber _
                  & "      <td width='144'valign='bottom' align='left'>" _
                  & Format(dtePickup, "m/d/yyyy") & "</td>" _
                  & "      <td width='237'valign='bottom' align='left'>" _
                  & strNotes & "</font></td>" _
                  & "   </tr>"
            End If
            Debug.Print "Line 2: " & strLine2
         
            strHTMLBody = strHTMLBody & strLine1 & strLine2
            rstSingle.MoveNext
         Loop
         
         strHTMLBody = strHeader & strHTMLBody & strSignature
         Debug.Print "Message HTML body: " & strHTMLBody
         
         msg.HTMLBody = strHTMLBody
         msg.Display
         
      End If
      rstAll.MoveNext
   Loop
   
ErrorHandlerExit:
   Exit Sub

ErrorHandler:
   MsgBox "Error No: " & Err.Number _
      & " in CreateEmails procedure; " _
      & "Description: " & Err.Description
   Resume ErrorHandlerExit

End Sub

Open in new window

0
 
shieldscoAuthor Commented:
How do I incorporate in my code
0
 
Helen FeddemaCommented:
I would set a strName variable to rst![FirstName] & " " & rst![LastName], and then use it in the line of code as follows:

sBody = "Hi, " & strName & "<br>.  In anticipation of CFRS Quarterly 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>Alfonso N. Giansanti II<br>Contractor to: ASFR Office of Finance Systems Policy & Oversight<br>U.S. Department of Health and Human Services<br><br>Deloitte Consulting LLP <br>Mobile: 860-908-8381 | FAX: 877-570-8542 | alfonso.giansanti@hhs.gov<br><br><br><br>FESM Customer Service </i></div></body></html>"

Open in new window


I think you might need to clean up redundant <br> codes -- Outlook HTML is tricky, and needs a lot of debugging.
0
 
shieldscoAuthor Commented:
Thanks so much
0

Featured Post

NEW Veeam Backup for Microsoft Office 365 1.5

With Office 365, it’s your data and your responsibility to protect it. NEW Veeam Backup for Microsoft Office 365 eliminates the risk of losing access to your Office 365 data.

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