Email to more than one addressees

[ypma]

Good evening I require a little help in my email function .
The following function sends an email to the first email address in the recordset I am trying to add a loop so that all the email addresses within the recordset receive this flyer. Plus each address is not aware of other addressees. So where do I place .movefirst , do until rst.EOF ,movenext and finally the loop. Any suggestions would be appreciated

#Public Function fctcontactemailremo() As String
Dim wd As Word.Application
Dim dbs As DAO.Database, rst As DAO.Recordset
Dim doc As Word.Document
Dim itm As Outlook.MailItem
Set dbs = CurrentDb
Set dbs = DBEngine(0)(0)
Dim blnWeOpenedWord As Boolean
On Error Resume Next
Dim ccto As String
Dim stDocName As String
Set rst = dbs.OpenRecordset("QryClientDetails")
Set wd = GetObject(, "Word.Application")
If wd Is Nothing Then
Set wd = CreateObject("Word.Application")
blnWeOpenedWord = True
End If
Set doc = wd.Documents.Open _
(FileName:="C:\SendingEmails\CONTACT EMAIL REMO.docx", ReadOnly:=True)
Set itm = doc.MailEnvelope.Item
With itm
.To = email
.Subject = "We have tried to call you."
.Send
End With
doc.Close wdDoNotSaveChanges
If blnWeOpenedWord Then
wd.Quit
End If

Set doc = Nothing
Set itm = Nothing
Set wd = Nothing

End Function#

Regards Ypma

 

[pbaldy]

Like:

  Do While Not rst.EOF
    Variable = Variable & rst!EmailField & ";"
    rst.MoveNext
  Loop

 

[Cronk]

.....Plus each address is not aware of other addressees....

If the recipients are unknown to each other, use BCC.


So adding to Paul's code

  Do While Not rst.EOF
    Variable = Variable & rst!EmailField & ";"
    rst.MoveNext
  Loop
  With itm

  .BCC= Variable
  ....

 

[ypma]

Pbaldy and Cronk, thank you very much for you very useful suggestions , I have one small problem where should I insert the additional code into my Function ? Would it be after the Send ?

Regards and thanks again Ypma.

I think I have got it and that is insert the code before the With itm ?

 

[pbaldy]

Yes, before the itm.

 

[Mark_]

Question,

In your posted code, you are filling in the EMail address being set to with

.Tp = email

Where are you generating the value for email? That is not included. That would be where you append all of the relevant Emails, prior to .Send which sends the email.

 

[ypma]

Hello Mark_. The code I posted works fine by using a word document linked to the query record set and the record set had only one record so only one email sent . I am now trying to learn how to send to a number of emails addressee which with the advise received , but although it sends emails to all addressees the word document is the same and all the addressees are Dear Bob and the other first names are not being pulled through .


If you have any comments on how I should address the problem I would be very grateful as I seem to be getting into a muddle
Regards Ypma

 

[Mark_]

So you want to change what is sent to be personalized for each recipient?

If so, do you have a different letter for each?

When I had to do this in the past, the process was to run a single record report that generated a PDF file. The same code that called the report and exported it would then create the Email and attached the just created PDF.

Are you looking for code to do something like this?

 

[ypma]

Mark Yes please , I had not thought of a PDF . I use the word merge, all the records in the records set are available but am only able to send an email to the first record in the record set. The field in my code example EMAIL is the name of my email field . hence to email .

Hope my explanation is clear

Regards Ypma

My user prefers the flyer details to be within the email as not all addresses would be able to open a PDF . As my code work for one addresses is it possible to loop through the word document in tandem with the loop on record set /

YPMA

 

[pbaldy]

In general, instead of building an address string within the loop I gave you, perform the whole process of sending an email. That means you send one email per record, and you can customize each based on data in the recordset.

 

[Gasman]

Here is my attempt of doing something quite similar.
This sends an email to the respective caseworker with tailored contents of their case in question.
I am using a HTML message and an Outlook template and I use the name from the contacts not hardcoded email addresses. This way if the email changes, I just need to change it in outlook.?

HTH

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
    
            ' 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")
            '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

 

[ypma]

Firstly thanks to all who responded to my request. In the end I achieved the result I desired as follows;

1 Created flyer in word
2 Merged the word doc to my database query , which contained the record set and the email addresses of the clients who need to receive this flyer.

3. Clicki Finish and Merge , Enter subject and then send to all.

4 Save word doc for future use which will be opened from the users database

The above is for anyone else who it might help

Regards Ypma