Sending Access reports by email as HTML

user_16215072 0
Viewed 454

I have an MS Access report that contains records of clients from one table (including the email address) and linked grouped records from other tables fetched by a Query.

I want to send the content of the report to each client separately in the body of the email (not as an attachment), I am able to get the text put in the body of the email but without the formatting and without the picture in the header.

I used the following code which runs behind a click of a button. I would appreciate if anyone can help with the formatting issue AND if there is a way I can automate sending the emails for my 200+ clients without clicking the button each time (like a loop or something):

Private Sub Command70_Click()
    Const ForReading = 1, ForWriting = 2, ForAppending = 8
    Dim appOutlook As Outlook.Application
    Dim MailOutlook As Outlook.MailItem
    Dim RTFBody
    Set appOutlook = CreateObject("Outlook.application")
    Set MailOutlook = appOutlook.CreateItem(olMailItem)
    DoCmd.OutputTo acOutputReport, "report1", acFormatHTML, "Report.htm", , , , acExportQualityScreen
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.OpenTextFile("Report.htm", ForReading, False, TristateTrue)
    RTFBody = f.ReadAll
    f.Close
    With MailOutlook
        .To = Me.Email.Value
        .CC = "anwarmirza.ridha@gmail.com"
        .Subject = Me.CR_Number & " " & Me.English_Name & " Weekly Report"
        .HTMLBody = "Dear Supplier" & Chr$(13) & Chr$(13) & _
                     RTFBody
                     
        .Send
        
    End With
    
    Set MailOutlook = Nothing
    Set appOutlook = Nothing
    
End Sub
ms-access vba html
1 Answers

Since MS Access reports are specialized rich text formats, conversion to HTML is not easily available. You would need to rebuild your report with HTML markup. However, there is another approach.

Consider creating an Outlook email template (.oft) with all needed images, colors, fonts, and other formatting with placeholders such as %...% markers:

Dear %ClientName%:

Thank you for purchase of %product% for %totalsales% on %salesdate%. We appreciate your business of %years% years.

%salestable%

Best wishes,
MyCompany Management

Then, have MS Access loop through a recordset of email details and text for message body to fill in placeholders. Handle any date/current/percent formatting in SQL or VBA. Because you need a group level multi-record summary, run two loops at 1) client level and 2) sales level.

strSQL = "SELECT ClientID, ClientName, ...email details... FROM myClientsTable"
Set clientRST = CurrentDb.OpenRecordset(strSQL)

Do While Not clientRST.EOF
    Set MailOutlook = appOutlook.CreateItemFromTemplate("C:\Path\To\ClientEmail.oft")

    strSQL = "SELECT Col1, Col2, Col3 ...sales details..." _
              & " FROM mySalesTable" _
              & " WHERE ClientID = " & clientRST!ClientID
    Set salesRST = CurrentDb.OpenRecordSet(strSQL)

    ' TABLE COLUMNS
    strTable = "<table><th>"
    For i = 1 to salesRST.Fields.Count
        strTable = strTable & "<td>" & salesRST.Fields(i-0).Name & "</td>"
    Next i
    strTable = strTable & "</th>"

    ' TABLE ROWS
    salesRST.MoveFirst
    While Not salesRst.EOF 
        strTable = strTable & "<tr>"
        For i = 1 to salesRST.Fields.Count
            strTable = strTable & "<td>" & salesRST.Fields(i-0).Value & "</td>"
        Next i
        strTable = strTable & "</tr>"
        salesRST.MoveNext
    Wend
    strTable = strTable & "</table>"
    salesRST.Close

    With MailOutlook
        ' DYNAMIC RECIPEINT
        .To = clientRST!Email
        .CC = "anwarmirza.ridha@gmail.com"

        ' DYNAMIC SUBJECT
        .Subject = clientRST!CR_Number & " " & clientRST!English_Name & " Weekly Report"

        ' REPLACE PLACEHOLDERS
        .HTMLBody = Replace(.HTMLBody, "%ClientName%", clientRST!ClientName)
        .HTMLBody = Replace(.HTMLBody, "%product%", clientRST!product)
        .HTMLBody = Replace(.HTMLBody, "%totalsales%", clientRST!totalsales)
        .HTMLBody = Replace(.HTMLBody, "%salesdate%", clientRST!salesdate)
        .HTMLBody = Replace(.HTMLBody, "%years%", clientRST!client_years)

        ' ADD SALES TABLE
        .HTMLBody = Replace(.HTMLBody, "%salestable%", strTable)

        .Send 
    End With

    Set MailOutlook = Nothing
    clientRST.MoveNext
Loop

clientRST.Close
user_14224510
Related