Solved

Sending an HTML email to multiple users via Access 2007

Posted on 2011-02-16
6
561 Views
Last Modified: 2012-05-11
Hi
Just a  quick question for someone more knowledgable than I with  Access.  
I have code working that runs from a form, building a query based on the form fields input.  This query is then used to generate an email distribution list and an email is then created to send to the recipients.

This works fine, however, I cannot get the email to go in HTML.  Whatever is entered into the form, is always send on one line without any line breaks. So is not really usefull.

Can anyone tell me how to set up the email to send as HTML  and as is seen when it is written into the form input field ?

Snippet of code is included as reference
where...
Sendoutlookemail is the procedure to send the email
errorHandling is an error handling procedure


thanks in advance
Private Sub Send_Mail_Click()
On Error GoTo Err_SendEmail

    Dim sTo As String
    Dim sCC As String
    Dim sBCC As String
    Dim sSubject As String
    Dim sBody As String
    Dim sAttachmentList As String
    Dim sReplyRecipient As String
    Dim oFSO As New FileSystemObject
    Dim oFS
    Dim db As DAO.Database
    Dim qryMail As QueryDef
    Dim MailList As DAO.Recordset

' this is a test to make sure the type of customer is chosen otherwise exit
'
  If Me.Choice = "" Then      ' from form
  MsgBox " You have to select a customer status "
  GoTo Exit_SendEmail
  End If
'
' You must key a semicolon between each email name
'
    sTo = ""
    sCC = ""
    sBCC = ""
    sReplyRecipient = "sales@domainname.com"
    sSubject = Me.Mess_Subject ' from form
    sBody = Me.mess_text       ' from form
'
'Path to the text file
 If Left(Me.Mail_Attachment_Path, 1) <> "<" Then
                Attachment = Me.Mail_Attachment_Path
                Attachment = 1
         Else
                Attachment = 0
 End If
'
'   does attachment exist
'
If Dir(Attachment) = "" Then
    MsgBox "Document not found. Please check path"
    Attachment = 0
End If
'
' Set up the database and query connections
'
Set db = CurrentDb                  'chosen database
' define query to be used from database
Set qryMail = db.QueryDefs("MyEmailAddresses")   
'
Set MailList = qryMail.OpenRecordset             '
' now, this is where we go through our list of addresses,
' adding them to the sCC list
'  LOOP through all the emails on the list
'
Do While Not MailList.EOF
       If MailList![Status] = Me.Choice Then
         NewEmail = MailList![EmailAddress]
         sBCC = sBCC & ";" & NewEmail
       End If
     MailList.MoveNext
   Loop
'
'send email but first check if there is an attachment
If Attachment = 0 Then   ' send without a file attachment
 Call SetupOutlookEmail(sTo, sCC, sBCC, sReplyRecipient, sSubject, sBody)
Else     ' send with a file attachment
 Call SetupOutlookEmail(sTo, sCC, sBCC, sReplyRecipient, sSubject, sBody, sAttachmentList)
End If

Exit_SendEmail:
    Exit Sub

Err_SendEmail:
    If Err.Number = -2147024894 Then 'Cannot find this file.  Verify the path and file name are correct.
        MsgBox "Email message was not sent.  Please verify the file " & sPathFile & " exists before attempting to resend the email.", vbCritical, "Invalid File Attachment"
        Exit Sub
    ElseIf Err.Number = -2147467259 Then 'Outlook does not recognize one or more names.
        MsgBox "Email message was not sent.  Please verify all user names and email addresses are valid before attempting to resend the email.", vbCritical, "Invalid Email Name"
        Exit Sub
    Else
        Call ErrorHandling(Err.Number, Err.Description, "sendmail_Click", "2-Email_clients_Monthly")
        Resume Exit_SendEmail
    End If
End Sub

----------------------------------------------
sendoutlookemail proc

Public Function SetupOutlookEmail(ByVal sTo As String, ByVal sCC As String, ByVal sBCC As String, ByVal sReplyRecipient As String, ByVal sSubject As String, ByVal sBody As String, ParamArray sAttachmentList() As Variant) As Boolean
On Error GoTo Err_SetupOutlookEmail
    
    Dim objOLApp As Object
    Dim outItem As Object
    Dim outFolder As Object
    Dim DestFolder As Object
    Dim outNameSpace As Object
    Dim lngAttachment As Long

    Set objOLApp = CreateObject("Outlook.Application")
    Set outNameSpace = objOLApp.GetNamespace("MAPI")
    Set outFolder = outNameSpace.GetDefaultFolder(6)
    Set outItem = objOLApp.CreateItem(0)

    outItem.To = sTo
    outItem.CC = sCC
    outItem.BCC = sBCC
    outItem.Subject = sSubject
    outItem.Body = sBody
    outItem.ReplyRecipients.Add sReplyRecipient
    outItem.ReadReceiptRequested = False

    With outItem.Attachments
        For lngAttachment = LBound(sAttachmentList) To UBound(sAttachmentList)
            .Add sAttachmentList(lngAttachment)
        Next lngAttachment
    End With

 '   outItem.Send
    outItem.Display 
'setup and open email in edit mode instead of sending the email
    SetupOutlookEmail = True

Exit_SetupOutlookEmail:
    On Error Resume Next
    Set outItem = Nothing
    Set outFolder = Nothing
    Set outNameSpace = Nothing
    Set objOLApp = Nothing
    Exit Function

Err_SetupOutlookEmail:
    If Err.Number = 287 Then 'User stopped Outlook from sending email.
        MsgBox "User aborted email.", vbInformation, "Email Cancelled"
        Resume Exit_SetupOutlookEmail
    Else
        Call ErrorHandling(Err.Number, Err.Description, "SetupOutlookEmail module", "Function in Main_window_Open_Module")
        Resume Exit_SetupOutlookEmail
    End If

End Function

Open in new window

0
Comment
Question by:ianLMurdoch
6 Comments
 
LVL 31

Accepted Solution

by:
Helen_Feddema earned 250 total points
ID: 34907622
Here is some code for creating HTML emails and sending them to recipients.  Note that the HTML syntax used in HTML emails is rather old (say mid-90's vintage).  
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 email for this customer
         strHTMLBody = ""
         strHeader = "<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
 
LVL 12

Expert Comment

by:Paul_Harris_Fusion
ID: 34907650
We have an app which sends mail via SMTP rather via outlook.  
With our approach,  we have to format the email text as html.    i.e. with all the correct HTML tags.  
If you using text entered in a text box as your email body,  you would need to preprocess it first and add it HTML tags.

e.g. replace vbCRLF characters with <br/>

I would suggest you create a piece of HTML text using word or something like that,  paste the HTML into your text box and see if the resulting email is what you expect.    That would give you a clue about how to format the text for your email.
0
 
LVL 12

Expert Comment

by:Paul_Harris_Fusion
ID: 34907671
FYI,  the approach we took was to create an HTML email template with some replaceable strings
e.g. %info_text%
Our preprocessing loading some text from a database,  replaced carriage returns with <br/>,  then used the resulting string to replace %info_text% in our template.
0
How to run any project with ease

Manage projects of all sizes how you want. Great for personal to-do lists, project milestones, team priorities and launch plans.
- Combine task lists, docs, spreadsheets, and chat in one
- View and edit from mobile/offline
- Cut down on emails

 
LVL 11

Expert Comment

by:RgGray3
ID: 34907672
I struggled with this a while back...
I ended by going with a 3rd parth solution (FMS emailer)

Alot depends on how your going to use this...
Administrativly (you will manage the process as the IT guy)
or Programatically (set it up for the users to manage)

We ended up using a standalone HTML editor for composition (thus inserting the proper tags within the body text)
then used the FMS emailer to do the sending (which can be configured so a preconfigured job can be sent programatically)

So reviewing your question...  it sounds like your not getting the HTML tags within your body text.

How are you entering the email...  into a text control, a RichText control?
0
 
LVL 21

Assisted Solution

by:Boyd (HiTechCoach) Trimmell, Microsoft Access MVP
Boyd (HiTechCoach) Trimmell, Microsoft Access MVP earned 250 total points
ID: 34907796
If you look at the example Helen posted you will see that it has two small different that change it ti HTML:

 
.BodyFormat = olFormatHTML

Open in new window


msg.HTMLBody

Open in new window


To apply this to your VBA code you need to make a few adjustment to one of your functions:

Try this:
Public Function SetupOutlookEmail(ByVal sTo As String, ByVal sCC As String, ByVal sBCC As String, ByVal sReplyRecipient As String, ByVal sSubject As String, ByVal sBody As String, ParamArray sAttachmentList() As Variant) As Boolean
On Error GoTo Err_SetupOutlookEmail
    
    Dim objOLApp As Object
    Dim outItem As Object
    Dim outFolder As Object
    Dim DestFolder As Object
    Dim outNameSpace As Object
    Dim lngAttachment As Long

    Set objOLApp = CreateObject("Outlook.Application")
    Set outNameSpace = objOLApp.GetNamespace("MAPI")
    Set outFolder = outNameSpace.GetDefaultFolder(6)
    Set outItem = objOLApp.CreateItem(0)

    outItem.To = sTo
    outItem.CC = sCC
    outItem.BCC = sBCC
    outItem.Subject = sSubject

    ' this is for plain text  
    ' outItem.Body = sBody

    ' for HTML in the body of the message use thie two line
    
     outItem.BodyFormat = olFormatHTML 
     outItem.MTMLBody = sBody


    outItem.ReplyRecipients.Add sReplyRecipient
    outItem.ReadReceiptRequested = False

    With outItem.Attachments
        For lngAttachment = LBound(sAttachmentList) To UBound(sAttachmentList)
            .Add sAttachmentList(lngAttachment)
        Next lngAttachment
    End With

 '   outItem.Send
    outItem.Display 
'setup and open email in edit mode instead of sending the email
    SetupOutlookEmail = True

Exit_SetupOutlookEmail:
    On Error Resume Next
    Set outItem = Nothing
    Set outFolder = Nothing
    Set outNameSpace = Nothing
    Set objOLApp = Nothing
    Exit Function

Err_SetupOutlookEmail:
    If Err.Number = 287 Then 'User stopped Outlook from sending email.
        MsgBox "User aborted email.", vbInformation, "Email Cancelled"
        Resume Exit_SetupOutlookEmail
    Else
        Call ErrorHandling(Err.Number, Err.Description, "SetupOutlookEmail module", "Function in Main_window_Open_Module")
        Resume Exit_SetupOutlookEmail
    End If

End Function

Open in new window

0
 

Author Closing Comment

by:ianLMurdoch
ID: 34941239
The HTML reference was what I needed thanks to everyone for your help.

Ian
0

Featured Post

Backup Your Microsoft Windows Server®

Backup all your Microsoft Windows Server – on-premises, in remote locations, in private and hybrid clouds. Your entire Windows Server will be backed up in one easy step with patented, block-level disk imaging. We achieve RTOs (recovery time objectives) as low as 15 seconds.

Join & Write a Comment

Experts-Exchange is a great place to come for help with solutions for your database issues, and many problems are resolved within minutes of being posted.  Others take a little more time and effort and often providing a sample database is very helpf…
Preface: When I started this series, I used the term CommandBars because that is the Office Object class that it discusses. Unfortunately, when Microsoft introduced Office 2007, they replaced the standard Commandbar menus with "The Ribbon" and rem…
In Microsoft Access, learn the trick to repeating sub-report headings at the top of each page. The problem with sub-reports and headings: Add a dummy group to the sub report using the expression =1: Set the “Repeat Section” property of the dummy…
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…

758 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

22 Experts available now in Live!

Get 1:1 Help Now