Emailing Exported Excel Files From Within Access (1 Viewer)

[psyc0tic1]

I have a little form that has 3 buttons on it.

One button generates an export to Excel of one kind of data.
Another button generates an export to Excel of another kind of data.
The third button attaches the exported Excel files to an email in Outlook and sends it without having to see it.

This works perfectly... however I am using this code I found on the net from searching:

Private Sub SendEMail_Click()
  Dim appOutLook As Outlook.Application
  Dim MailOutLook As Outlook.MailItem
  Dim strPath As String
  Dim strFileName As String
  Set appOutLook = CreateObject("Outlook.Application")
  Set MailOutLook = appOutLook.CreateItem(olMailItem)
  With MailOutLook
    .BodyFormat = olFormatRichText
    .To = "name@address.com"
    '.cc = ""
    '.bcc = ""
    .Subject = "Test"
    .HTMLBody = "Testing"
    'add all Excel files
    strPath = "W:\My Folder\Databases\Weekly Reports\"
    strFileName = Dir(strPath & "*.xlsx")
    If strFileName <> "" Then
        While strFileName <> ""
          .Attachments.Add (strPath & strFileName)
          strFileName = Dir()
        Wend
    Else
        MsgBox "No file matching " & strPath & "*.csv " & " found." & vbCrLf & _
                "Processing terminated."
        Exit Sub
    End If
    .Send
    '.Display      'Used during testing without sending (Comment out .Send if using this line)
  End With
End Sub

Is anyone willing to help me with some code to replace the part where it sends to a hard-coded email address to using email addresses from the table that holds the users information (tbl_users) but only sends to the ones with specific access levels i.e. tbl_users field AccessLvl with a value of 1, 2, 3, or 4 etc?

I have been searching and searching but I must be using the wrong words... I have not found anything like this yet.

Thank you very much in advance if you are willing to help.

 

[Ranman256]

sub SendEmails()
dim vDir, vFile

  vDir = "c:\temp\"
      vFile = vDir & "Bob.xls"
      email1 "bob@yahoo.com", "subject A" , "bobs body", vFile

     vFile = vDir & "sam.xls"
     email1 "sam@yahoo.com", "subject B" , "sams body", vFile
end sub



Public Function Email1(ByVal pvTo, ByVal pvSubj, ByVal pvBody) As Boolean
Dim oApp As Outlook.Application
Dim oMail As Outlook.MailItem
'-------
'YOU MUST ADD THE OUTLOOK APP IN REFERENCES!!!   checkmark MICROSOFT OUTLOOK OBJECT LIBRARY in the vbE menu, Tools, References
'-------

On Error GoTo ErrMail

Set oApp = CreateObject("Outlook.Application")
Set oMail = oApp.CreateItem(olMailItem)

With oMail
    .To = pvTo
    .Subject = pvSubj
    .Body = pvBody

    .Attachments.Add activeworkbook.FullName, olByValue, 1
    
    .Send
End With

EmailO = True
Set oMail = Nothing
Set oApp = Nothing
Exit Function

ErrMail:
MsgBox Err.Description, vbCritical, Err
Resume Next
End Function

you can also use a listbox to scan the list of emails.

 

[psyc0tic1]

Maybe I can explain it a little better... pardon me if I didn't before.

The exported Excel files are generated every Monday and I (before) would then attach them to an email and send them out to a contact list I have in Outlook. They all receive the same email every time.

I have my users table which consists of Admin (me), managers, inspectors, testers, deactivated etc.

I do not want to send out these weekly reports to myself nor to the managers or deactivated users... just the inspectors and testers but this is a long list and it can be ever-changing due to people leaving the company so I thought it might be better to look in the users table (tbl_users) at the field (AccessLvl) for a 1, 2, 3 or 4 etc. whichever ID number of the access level I choose and that way it will always include everyone in the chosen access levels without me having to hard-code their addresses in the VB and not have to deal with the ever-changing contact list in Outlook or taking out addresses when I change their access level to deactivated.

Something like what you see above the line for the email address using the credentials module:

Private Sub SendEMail_Click()
  Dim appOutLook As Outlook.Application
  Dim MailOutLook As Outlook.MailItem
  Dim strPath As String
  Dim strFileName As String
  Set appOutLook = CreateObject("Outlook.Application")
  Set MailOutLook = appOutLook.CreateItem(olMailItem)
  With MailOutLook
    .BodyFormat = olFormatRichText

If Credentials.AccessLvlID <> 1 And Credentials.AccessLvlID <> 3 Then

    .To = "SOMETHING HERE DO NOT KNOW WHAT"
    '.cc = ""
    '.bcc = ""
    .Subject = "Test"
    .HTMLBody = "Testing"
    'add all Excel files
    strPath = "W:\My Folder\Weekly Reports\"
    strFileName = Dir(strPath & "*.xlsx")
    If strFileName <> "" Then
        While strFileName <> ""
          .Attachments.Add (strPath & strFileName)
          strFileName = Dir()
        Wend
    Else
        MsgBox "No file matching " & strPath & "*.csv " & " found." & vbCrLf & _
                "Processing terminated."
        Exit Sub
    End If
    '.Send
    .Display      'Used during testing without sending (Comment out .Send if using this line)
  End With
End Sub

Did that make more sense?

 

[Cronk]

Use a recordset of the users you want to mail to.

set rst = currentdb.openrecordset("select EmailAddress from tbl_users where accessLevel =1")
rst.movefirst
do while not rst.eof
  strEmailTo= strEmailTo & "; " & rst!EmailAddress

  rst.movenext

loop


.To= strEmailTo

 

[psyc0tic1]

Use a recordset of the users you want to mail to.

set rst = currentdb.openrecordset("select EmailAddress from tbl_users where accessLevel =1")
rst.movefirst
do while not rst.eof
  strEmailTo= strEmailTo & "; " & rst!EmailAddress

  rst.movenext

loop


.To= strEmailTo

I am no doubt adding this in the wrong place or something... pardon my extremely novice Access abilities.

The code looks like this now but only displays strEmailTo in the addresses line of the email rather than the actual addresses.

Private Sub SendEMail_Click()
  Dim appOutLook As Outlook.Application
  Dim MailOutLook As Outlook.MailItem
  Dim strPath As String
  Dim strFileName As String
  Set appOutLook = CreateObject("Outlook.Application")
  Set MailOutLook = appOutLook.CreateItem(olMailItem)
  Set rst = CurrentDb.OpenRecordset("select EmailAddress from tbl_users where AccessLvl =2")
rst.MoveFirst
    Do While Not rst.EOF
  strEmailTo = strEmailTo & "; " & rst!EmailAddress

  rst.MoveNext

Loop

  With MailOutLook
    .BodyFormat = olFormatRichText
    .To = "strEmailTo"
    '.cc = ""
    '.bcc = ""
    .Subject = "Test"
    .HTMLBody = "Testing"
    'add all Excel files
    strPath = "W:\My Folder\Weekly Reports\"
    strFileName = Dir(strPath & "*.xlsx")
    If strFileName <> "" Then
        While strFileName <> ""
          .Attachments.Add (strPath & strFileName)
          strFileName = Dir()
        Wend
    Else
        MsgBox "No file matching " & strPath & "*.xlsx " & " found." & vbCrLf & _
                "Processing terminated."
        Exit Sub
    End If
    '.Send
    .Display      'Used during testing without sending (Comment out .Send if using this line)
  End With
End Sub

 

[Cronk]

Richard,


If I may offer a bit of unsolicited advice. Try to follow what the code is doing, line by line.



strEmailTo is a variable which will hold the string of email addresses. It should be declared along with the others you have used eg strFileName


At the end of the loop, strEmailTo has all the addresses, separated by semi colons.


Don't use the name of the variable in quotes because as you no doubt see, that is what is in the To field. Just like you have used
.

Attachments.Add (strPath & strFileName)

and not put quotes around those variable names, use

.To = strEmailTo

as I did in my previous post.

 

[psyc0tic1]

Richard,


If I may offer a bit of unsolicited advice. Try to follow what the code is doing, line by line.



strEmailTo is a variable which will hold the string of email addresses. It should be declared along with the others you have used eg strFileName


At the end of the loop, strEmailTo has all the addresses, separated by semi colons.


Don't use the name of the variable in quotes because as you no doubt see, that is what is in the To field. Just like you have used
.

Attachments.Add (strPath & strFileName)

and not put quotes around those variable names, use

.To = strEmailTo

as I did in my previous post.

Thank you for the heads up on that one... I keep forgetting about the quotes.

Works great for a single access level... still working on making it work for multiple access level id's but I will get it.

 

[psyc0tic1]

For anyone interested in that last solution the line became this:

Set rst = CurrentDb.OpenRecordset("select EmailAddress from tbl_users where AccessLvl in (2, 3, 4) ")

Thank you all for the help

 

[psyc0tic1]

Yea... definately in over my head with this one...

I was trying to add a CC to the email that gets generated so I added another table with a different set of people and their addresses and I tried adding in another recordset to the code and I got no errors but it added the first email address from the tbl_receivers 21 times in the CC field (there should have only been 2 email addresses there) of the email (which was the same number of addresses that was added to the To field drawn from tbl_users).

Will someone please show the code I missed to make this work correctly?

Option Compare Database
Option Explicit

Public Function EmailNotice()

  Dim appOutLook As Outlook.Application
  Dim MailOutLook As Outlook.MailItem
  Dim strPath As String
  Dim strFileName As String
  Dim rst2 As DAO.Recordset
  Dim strEMailCC As String
  
  'CR - added next 2 lines
  Dim strEMailTo As String
  Dim rst As DAO.Recordset

  Set appOutLook = CreateObject("Outlook.Application")
  Set MailOutLook = appOutLook.CreateItem(olMailItem)
  Set rst = CurrentDb.OpenRecordset("select EmailAddress from tbl_users where AccessLvl in (2, 3, 4) ")
  Set rst2 = CurrentDb.OpenRecordset("select EmailAddress from tbl_receivers where Active = True ")
    rst.MoveFirst
        
    Do While Not rst.EOF
  strEMailTo = strEMailTo & "; " & rst!EmailAddress
  strEMailCC = strEMailCC & "; " & rst2!EmailAddress

  rst.MoveNext

Loop
    With MailOutLook
    .BodyFormat = olFormatRichText
    
    .To = strEMailTo
    .CC = strEMailCC
    .Subject = "Monthly Electrical Audit Alert - " & Date
    .HTMLBody = "<HTML><BODY><font face=Calibri>Attention all,<BR><BR>This email is to alert you that it is time to perform the monthly electrical parts audit.<BR><BR>Receivers, please pull the newest P.O. of electrical parts to be audited and contact the auditor with part numbers and their P.O. quantities.<BR><BR>Auditors, you will need to coordinate with receiving to have these parts delivered to you.<BR><BR><b>Thank you everyone for all of your efforts!</b></font></BODY></HTML>"
'    .Send
    .Display      'Used during testing without sending (Comment out .Send if using this line)
  End With
End Function

 

[Gasman]

You are not clearing the CC field after email is sent?
Nor are you moving through that recordset?

You might want to removed the [Solved] until it actually is?

 

[psyc0tic1]

You are not clearing the CC field after email is sent?
Nor are you moving through that recordset?

If you have identified what I am not doing in the code... can you help with the code additions to accomplish those things? Obviously I only minimally grasp what is going on in there

 

[Gasman]

I've forgotten what you are trying to do.?
Is it send one email to a bunch of people in the To field and a bunch of people in the CC field.?

 

[psyc0tic1]

I've forgotten what you are trying to do.?
Is it send one email to a bunch of people in the To field and a bunch of people in the CC field.?

Correct... I have 2 tables

Table 1 - tbl_users (with AccessLvl 2, 3, 4)
Table 2 - tbl_receivers (with Active = true)

I wanted to have the users in the .To and the receivers in the .CC

 

[Gasman]

OK,
Read rst recordset until rst.EOF and build the To string
Read rst2 recordset until rst2.EOF and build the CC string

Do these in separate blocks of code, but they will be almost identical.

Then construct the email and send.

 

[psyc0tic1]

OK,
Read rst recordset until rst.EOF and build the To string
Read rst2 recordset until rst2.EOF and build the CC string

Do these in separate blocks of code, but they will be almost identical.

Then construct the email and send.

ahhh! I see what you mean. This works!

Dim strFileName As String
  Dim rst As DAO.Recordset
  Dim rst2 As DAO.Recordset
  Dim strEMailTo As String
  Dim strEMailCC As String

  Set appOutLook = CreateObject("Outlook.Application")
  Set MailOutLook = appOutLook.CreateItem(olMailItem)
  Set rst = CurrentDb.OpenRecordset("select EmailAddress from tbl_users where AccessLvl in (2, 3, 4) ")
  
    rst.MoveFirst
        
    Do While Not rst.EOF
  strEMailTo = strEMailTo & "; " & rst!EmailAddress

  rst.MoveNext
  
  Loop
    With MailOutLook
    .BodyFormat = olFormatRichText
    
    .To = strEMailTo
  
  Set rst2 = CurrentDb.OpenRecordset("select EmailAddress from tbl_receivers where Active = True ")
  
    rst2.MoveFirst
    
    Do While Not rst2.EOF
  strEMailCC = strEMailCC & "; " & rst2!EmailAddress
  
  rst2.MoveNext

    Loop
    With MailOutLook
    .BodyFormat = olFormatRichText
    .CC = strEMailCC
    .Subject = "Monthly Electrical Audit Alert - " & Date
    .HTMLBody = "<HTML><BODY><font face=Calibri>Attention all,<BR><BR>This email is to alert you that it is time to perform the monthly electrical parts audit.<BR><BR>Receivers, please pull the newest P.O. of electrical parts to be audited and contact the auditor with part numbers and their P.O. quantities.<BR><BR>Auditors, you will need to coordinate with receiving to have these parts delivered to you.<BR><BR><b>Thank you everyone for all of your efforts!</b></font></BODY></HTML>"
'    .Send
    .Display      'Used during testing without sending (Comment out .Send if using this line)
  End With
  End With
End Function

Thanks a million Gasman!

 

[Gasman]

Hmm, I would have done it more like this

    Set rst = CurrentDb.OpenRecordset("select EmailAddress from tbl_users where AccessLvl in (2, 3, 4) ")

    rst.MoveFirst
        
    Do While Not rst.EOF
        strEMailTo = strEMailTo & "; " & rst!EmailAddress
        rst.MoveNext
    Loop
    
    Set rst2 = CurrentDb.OpenRecordset("select EmailAddress from tbl_receivers where Active = True ")
  
    rst2.MoveFirst
    
    Do While Not rst2.EOF
        strEMailCC = strEMailCC & "; " & rst2!EmailAddress
        rst2.MoveNext
    Loop
    
    'Now the outlook code

 

[psyc0tic1]

Hmm, I would have done it more like this

I see... that works as well so I changed it to your code

Option Compare Database
Option Explicit

Public Function EmailNotice()

  Dim appOutLook As Outlook.Application
  Dim MailOutLook As Outlook.MailItem
  Dim strPath As String
  Dim strFileName As String
  Dim rst As DAO.Recordset
  Dim rst2 As DAO.Recordset
  Dim strEMailTo As String
  Dim strEMailCC As String

  Set appOutLook = CreateObject("Outlook.Application")
  Set MailOutLook = appOutLook.CreateItem(olMailItem)
  Set rst = CurrentDb.OpenRecordset("select EmailAddress from tbl_users where AccessLvl in (2, 3, 4) ")
  
    rst.MoveFirst
        
    Do While Not rst.EOF
        strEMailTo = strEMailTo & "; " & rst!EmailAddress
        rst.MoveNext
  
    Loop
  
  Set rst2 = CurrentDb.OpenRecordset("select EmailAddress from tbl_receivers where Active = True ")
  
        rst2.MoveFirst
        
    Do While Not rst2.EOF
        strEMailCC = strEMailCC & "; " & rst2!EmailAddress
        rst2.MoveNext
    
    Loop
  
    With MailOutLook
    
    .To = strEMailTo
    .BodyFormat = olFormatRichText
    .CC = strEMailCC
    .Subject = "Monthly Electrical Audit Alert - " & Date
    .HTMLBody = "<HTML><BODY><font face=Calibri>Attention all,<BR><BR>This email is to alert you that it is time to perform the monthly electrical parts audit.<BR><BR>Receivers, please pull the newest P.O. of electrical parts to be audited and contact the auditor with part numbers and their P.O. quantities.<BR><BR>Auditors, you will need to coordinate with receiving to have these parts delivered to you.<BR><BR><b>Thank you everyone for all of your efforts!</b></font></BODY></HTML>"
'    .Send
    .Display      'Used during testing without sending (Comment out .Send if using this line)

    End With
    
End Function

Is it also possible to pull values from a table and put them in the body? I ask because I want to show a list of part numbers that need attention but do not know what to do because the body is in HTML format

 

[Gasman]

Yes, but you need to build the html in some way.?

Here is one of mine which has the most tailoring.

Private Sub cmdEmail_Click()
    On Error GoTo Err_Handler
    ' Automate the routine to send notifications of Payments and deposits for clients
    Dim strFilter As String, strClientType As String
    Dim strDate As String, strSQLEmail As String
    Dim strType As String, strClient As String, str3rdID As String, str3rdParty As String, str3rdPartyType As String, strAmount As String, strRef As String, strMethod As String
    Dim strCaseWorker As String, strDatetype As String, strPad As String, strEndPad As String, strPadCol As String, strBlankLine As String, strNotes As String
    Dim strBalance As String
    Dim iColon As Integer
    Dim lngCurrentRec As Long
    Dim blnDisplayMsg As Boolean, blnSameEmail As Boolean
    Dim db As Database
    Dim rs As DAO.Recordset, rsCW As DAO.Recordset
    Dim blnSameClientType As Boolean

    ' Now the Outlook variables
    Dim objOutlook As Outlook.Application
    Dim objOutlookMsg As Outlook.MailItem
    Dim objOutlookRecip As Outlook.Recipient
    Dim objOutlookAttach As Outlook.Attachment
    Dim strSigPath As String, strSignature As String, strAttachFile As String
    Dim strHeader As String, strFooter As String, strBody As String, strTemplatePath As String, strAppdata As String
    Dim intBody As Integer

    ' Set up HTML tags
    strPad = "<tr><td>"
    strEndPad = "</td></tr>"
    strPadCol = "</td><td>"
    strBlankLine = "<tr></tr>"


    On Error GoTo Err_Handler

    'Establish all the static Outlook Data

    ' Get appdata path
    strAppdata = Environ("Appdata")
    
    ' Set paths
    strTemplatePath = strAppdata & "\Microsoft\Templates"
    strSigPath = strAppdata & "\Microsoft\Signatures\Ssafa.htm"
    
    
    'Get the signature if it exists
    If Dir(strSigPath) <> "" Then
        strSignature = GetBoiler(strSigPath)
        intBody = InStr(strSignature, "<div class=WordSection1>")
        'intBody = InStr(strSignature, "<BODY>")
        strHeader = Left(strSignature, intBody + 24) ' 5
        strFooter = Mid(strSignature, intBody + 24) ' 6
    End If

    ' See if Outlook is open, otherwise open it
    'If fIsOutlookRunning = False Then
    Set objOutlook = CreateObject("Outlook.Application")
    'Call OpenOutlook
    'Pause (5)
    ' Else
    'Set objOutlook = GetObject(, "Outlook.Application")
    'End If
    
    ' Make sure we save any changed data and then get recordset
    If Me.Dirty Then Me.Dirty = False
    ' Update the status bar
    SetStatusBar ("Collecting records.....")

    strSQLEmail = "SELECT Emails.* From Emails "
    strSQLEmail = strSQLEmail & "WHERE (((Emails.EmailStatus) = 'Yes')) "
    strSQLEmail = strSQLEmail & "ORDER BY Emails.Client, Emails.TranType, Emails.ID, Emails.TransactionDate;"
    ' Create the Outlook session.
    'Set objOutlook = GetObject(, "Outlook.Application")
    'Set objOutlook = New Outlook.Application
    
    ' Open lookup table for Email CC Name (normally a Case Worker)
    Set db = CurrentDb
    Set rsCW = db.OpenRecordset("SELECT * from Lookups WHERE DataType = 'Email'")
    ' Save the current record position
    lngCurrentRec = Me.CurrentRecord
    ' Now get the data for the emails
    Set rs = db.OpenRecordset(strSQLEmail)
    
    ' Now set the filter to get just the rows we want
    ' strFilter = "Yes"
    
    ' Me.Filter = "EmailStatus = """ & strFilter & """"
    'Me.FilterOn = True


    ' Decide whether to display or just send emails
    blnDisplayMsg = Me.chkDisplay

    'Set rs = Me.RecordsetClone
    rs.MoveFirst

    SetStatusBar ("Creating Emails.....")
    ' Now walk through each record
    Do While Not rs.EOF
        ' Set flag and field to check
        blnSameClientType = True
        strClientType = rs!Client & rs!TranType
        strType = rs!TranType
        
        ' Create the message if first time we are in a different client or tran type.
        'Set objOutlookMsg = objOutlook.CreateItemFromTemplate(strTemplatePath & "\SSAFA Email.oft")
        Set objOutlookMsg = objOutlook.CreateItemFromTemplate(strTemplatePath & "\SSAFA Email.oft")
        With objOutlookMsg
            ' Set the category
            .Categories = "SSAFA"
            .Importance = olImportanceHigh
            ' Add the To recipient(s) to the message.
            Set objOutlookRecip = .Recipients.Add("Jim Needs - SSAFA Swansea")
            objOutlookRecip.Type = olTo
            
            ' Send to Jim personal email as well
            Set objOutlookRecip = .Recipients.Add("Jim Needs - Personal")
            objOutlookRecip.Type = olBCC

    
            ' Add the CC recipient(s) to the message.
            If rs!CCOffice Then
                Set objOutlookRecip = .Recipients.Add("** SSAFA West Glamorgan Branch")
                objOutlookRecip.Type = olCC
            End If
            
            ' Need to get the Case Worker name from table'
            If rs!CaseWorker > 0 Then
                rsCW.FindFirst "[ID] = " & rs!CaseWorker
                strCaseWorker = rsCW!Data
            Else
                strCaseWorker = ""
            End If

            If strCaseWorker <> "" Then
                Set objOutlookRecip = .Recipients.Add(strCaseWorker)
                objOutlookRecip.Type = olCC
            End If
    
            ' Set the Format, Subject, Body, and Importance of the message.
            '.BodyFormat = olFormatHTML
            strClient = rs!Client


            If strType = "Payment" Then
                .Subject = " Payment Made - " & strClient
            Else
                .Subject = "Deposit Received - " & strClient
            End If
            ' Now start the email with header
            'iColon = InStr(strClient, ":")
            ' If iColon = 0 Then iColon = Len(strClient) + 1
            .HTMLBody = strHeader & "<table border = '0' cellpadding = '5' cellspacing = '5'>"
            '    .HTMLBody = .HTMLBody & "<td>" & "Client: " & strPadCol & Left(strClient, iColon - 1) & strEndPad
            'End If

        End With

        Do While blnSameClientType
            strDate = rs!TransactionDate
            strType = rs!TranType
            str3rdParty = rs!ThirdParty
            strAmount = Format(rs!Amount, "Currency")
            'strBalance = Format(rs!Balance, "Currency")
            strBalance = Format(DSum("Amount", "Emails", "CMS = " & rs!CMS & " AND ID <= " & rs!ID), "Currency")
            'Now Calculated on the fly
            'strBalance = Format(rs!Balance, "Currency") ' was Format(DSum("[Amount]", "Emails", "[CMS]=" & rs!CMS & " AND ID <= " & rs!ID), "Currency")
            
            strRef = rs!Reference
            strMethod = rs!Method
            
            'strDatetype = "Date "
            If strType = "Payment" Then
                str3rdPartyType = "Recipient:"
                strDatetype = "Date Paid:"
            Else
                str3rdPartyType = "From Donor:"
                strDatetype = "Received:"
            End If

            strNotes = Nz(rs!Notes, "")
        
        
            ' Now build the body of the message
            
            ' Make sure we have a colon in client, else use whole field
            
            ' Now add the variable data
            With objOutlookMsg
'                .Body = .Body & PadR(str3rdPartyType, " ", 30) & str3rdParty & vbCrLf
'                .Body = .Body & PadR(strDatetype, " ", 30) & strDate & vbCrLf
'                .Body = .Body & PadR("Method:", " ", 30) & strMethod & vbCrLf
'                .Body = .Body & PadR("Reference:", " ", 28) & strRef & vbCrLf
'                .Body = .Body & PadR("Amount:", " ", 30) & strAmount & vbCrLf
'                .Body = .Body & PadR("Balance:", " ", 30) & strBalance & vbCrLf

                
                .HTMLBody = .HTMLBody & strPad & str3rdPartyType & strPadCol & str3rdParty & strEndPad
                .HTMLBody = .HTMLBody & strPad & strDatetype & strPadCol & strDate & strEndPad
                .HTMLBody = .HTMLBody & strPad & "Method:" & strPadCol & strMethod & strEndPad
                .HTMLBody = .HTMLBody & strPad & "Reference:" & strPadCol & strRef & strEndPad
                .HTMLBody = .HTMLBody & strPad & "Amount:" & strPadCol & strAmount & strEndPad
                .HTMLBody = .HTMLBody & strPad & "Balance:" & strPadCol & strBalance & strEndPad
                ' Add any notes if they exist
                If Len(strNotes) > 0 Then
                    .HTMLBody = .HTMLBody & strPad & "Notes:" & strPadCol & strNotes & strEndPad
                    '.Body = .Body & PadR("Notes: ", " ", 30) & strNotes & vbCrLf

                End If
'                ' Add blank line for next set
                '.Body = .Body & vbCrLf
                .HTMLBody = .HTMLBody & "<tr></tr><tr></tr>"
            End With
            
            'Now update the record
            rs.Edit
            rs!EmailStatus = "Sent"
            rs!EmailDate = Date
            rs.Update

            ' Now get next record
            rs.MoveNext
            ' Has client or tran type changed?
            If Not rs.EOF Then
                If strClientType = rs!Client & rs!TranType Then
                    blnSameClientType = True
                Else
                    blnSameClientType = False
                End If
            Else
                blnSameClientType = False
            End If
        Loop                                     ' End blnClientType loop
        
        ' Now add the footer
        With objOutlookMsg
            .HTMLBody = .HTMLBody & "</table>" & strFooter
            '.Importance = olImportanceHigh  'High importance
            'Debug.Print strHeader
            'Debug.Print .htmlbody
            'Debug.Print strFooter
            ' Resolve each Recipient's name.
            For Each objOutlookRecip In .Recipients
                objOutlookRecip.Resolve
            Next
    
            ' Should we display the message before sending?
            '.SendUsingAccount = objOutlook.Session.Accounts.Item(4)
            If blnDisplayMsg Then
                .Display
            Else
                .Save
                .Send
            End If
        End With
    
            
    Loop
    ' Switch off the filter and release recordset object, and go back to record we were on
    ' Me.FilterOn = False
    SetStatusBar ("Emails created.....")
    DoCmd.GoToRecord , , acGoTo, lngCurrentRec
    cmdRequery_Click
Proc_Exit:
    Set objOutlook = Nothing
    Set objOutlookMsg = Nothing
    Set objOutlookRecip = Nothing
    Set objOutlookAttach = Nothing
    Set rs = Nothing
    Set rsCW = Nothing
    Set db = Nothing
    SetStatusBar (" ")
    Exit Sub
    
Err_Handler:
    MsgBox Err.Number & " " & Err.Description
    Resume Proc_Exit



End Sub

 

[psyc0tic1]

Gasman... would it be okay with you to post a screenshot of the output of that code? (with all sensitive data blacked out of course) so I can follow what is being done with the HTML code?

 

[Gasman]

It is not sensitive. That is why I use names and not actual email addresses.
If it had been, I would have changed the code before posting.

You would need to change the recordset.

FWIW here is a display, the contents just changes depending on deposit or payment, but you should get the idea.

HTH