recipients multiple emails from table

lookforsmt · Dec 6, 2017

Hi! I am trying to send email to multiple recipients, but it only sends to one email address.

the code that i am using on the on-click is

Code:

Private Sub cmdMail_Click()
    Dim mess_body As String, StrFile As String, strPath As String
    Dim appOutLook As Object
    Dim MailOutLook As Object
    Dim rs As dao.Recordset

    Set appOutLook = CreateObject("Outlook.Application")
    Set MailOutLook = appOutLook.CreateItem(0)

    Set rs = CurrentDb.OpenRecordset("Select * from Mail where Mail.chk=True")
'    Set rs = CurrentDb.OpenRecordset("SELECT mail.id FROM mail WHERE mail.chk = " & True)
        
    '~~> Change path here
    strPath = "E:\Test Folder1\Reports\"

    With MailOutLook
        For i = 1 To rs.RecordCount
            If rs.Fields("chk") = True Then Else
                .To = rs.Fields("email_ID").Value
            rs.MoveNext
        Next i
        
        .Subject = "Report"
        .HTMLBody = "Report"

        '~~> *.* for all files
        StrFile = Dir(strPath & "*.*")

        Do While Len(StrFile) > 0
            .Attachments.Add strPath & StrFile
            StrFile = Dir
        Loop

        '.DeleteAfterSubmit = True
        .Send
    End With

    MsgBox "Reports have been sent", vbOKOnly
    
End Sub

I want the code to send to multiple recipients if the criteria is "True"
Any help pls

pbaldy · Dec 6, 2017

You have to concatenate. I'd use a string variable, but this may work:

.To = .To & rs.Fields("email_ID").Value & ";"

lookforsmt · Dec 6, 2017

thanks pbaldy. I tried using the code, its send email to the 1st recipient.

There are 4 email address and 3 are ticked, but it sends to the first one only.

Mark_ · Dec 6, 2017

I'd replace the

Code:

        For i = 1 To rs.RecordCount
            If rs.Fields("chk") = True Then Else
                .To = rs.Fields("email_ID").Value
            rs.MoveNext
        Next i

with

Code:

DIM asEmail as String
        asEmail = ""
        For i = 1 To rs.RecordCount
            If rs.Fields("chk") = True Then Else
                asEmail = asEmail & rs.Fields("email_ID").Value & "; "
            rs.MoveNext
        Next i
        .To = asEmail

You can pretty it up by removing the trailing "; " also...

pbaldy · Dec 6, 2017

What exactly is your code now?

lookforsmt · Dec 7, 2017

HI! Mark
i have changed the code as suggested. The entire code now with the changes look like this. (Note i have still kept the old code with the ' mark to know the changes made

Code:

Private Sub cmdMail_b_Click()
    Dim mess_body As String, StrFile As String, strPath As String
    Dim appOutLook As Object
    Dim MailOutLook As Object
    Dim rs As dao.Recordset
    Dim asEmail As String
    
    Set appOutLook = CreateObject("Outlook.Application")
    Set MailOutLook = appOutLook.CreateItem(0)

    Set rs = CurrentDb.OpenRecordset("Select * from Mail where Mail.chk=True")
'    Set rs = CurrentDb.OpenRecordset("SELECT mail.id FROM mail WHERE mail.chk = " & True)
        
    '~~> Change path here
    strPath = "E:\Test Folder1\Reports\"

    With MailOutLook
'        For i = 1 To rs.RecordCount
'            If rs.Fields("chk") = True Then Else
           '     .To = rs.Fields("email_ID").Value
'                .To = .To & rs.Fields("email_ID").Value & ";"
'            rs.MoveNext
'        Next i
'--------------------------------------------------------------------------
        asEmail = ""
        For i = 1 To rs.RecordCount
            If rs.Fields("chk") = True Then Else
                asEmail = asEmail & rs.Fields("email_ID").Value & "; "
            rs.MoveNext
        Next i
        .To = asEmail
'--------------------------------------------------------------------------
        .Subject = "Report"
        .HTMLBody = "Report"

        '~~> *.* for all files
        StrFile = Dir(strPath & "*.*")

        Do While Len(StrFile) > 0
            .Attachments.Add strPath & StrFile
            StrFile = Dir
        Loop

        '.DeleteAfterSubmit = True
        .Send
    End With

    MsgBox "Reports have been sent", vbOKOnly
End Sub

it sends email to the 1st email address only, even though the 3rd & 4th row has check box "True"

i have attached snapshot of the table "Mail" how it is looks.
Thanks for your help. Sorry i couldn't reply as it was 1:00 am here. I don't know the time in your area. Sorry for the late response.

pbaldy · Dec 7, 2017

Since you're opening the recordset with only checked records, you don't need the test. Your Else is causing a problem. Try this:

Code:

        Do While Not rs.EOF
            asEmail = asEmail & rs.Fields("email_ID").Value & "; "
            rs.MoveNext
        Loop

lookforsmt · Dec 7, 2017

Thanks pbaldy, Its working now and email triggers to all the ones which are checked "True"

for all the other i am putting the code back with the changes
Thanks for your help.

Code:

Private Sub cmdMail_3ba_Click()
    Dim mess_body As String, StrFile As String, strPath As String
    Dim appOutLook As Object
    Dim MailOutLook As Object
    Dim rs As Recordset
    Dim asEmail As String
    
    Set appOutLook = CreateObject("Outlook.Application")
    Set MailOutLook = appOutLook.CreateItem(0)

    Set rs = CurrentDb.OpenRecordset("Select * from Mail where Mail.chk=True")
        
    '~~> Change path here
    strPath = "E:\Test Folder1\Reports\"

    With MailOutLook

    asEmail = ""
         Do While Not rs.EOF
            asEmail = asEmail & rs.Fields("email_ID").Value & "; "
            rs.MoveNext
        Loop
    .To = asEmail

        .Subject = "Report"
        .HTMLBody = "Report"

        '~~> *.* for all files
        StrFile = Dir(strPath & "*.*")

        Do While Len(StrFile) > 0
            .Attachments.Add strPath & StrFile
            StrFile = Dir
        Loop

        '.DeleteAfterSubmit = True
        .Send
    End With

    MsgBox "Reports have been sent", vbOKOnly
End Sub

I am trying to capture the body of the email with some text, will try and give you my feedback.
Thanks again

pbaldy · Dec 7, 2017

Happy to help!

Mark_ · Dec 7, 2017

One small item you may wish to add...

Right before the

Code:

.To = asEmail

add

Code:

IF asEmail = "" then MsgBox "NO recipients selected!!!"

Had this discussion with one of the people I work with. They just didn't understand why the program wasn't sending Email even though it was telling them they hadn't selected anyone...

lookforsmt · Dec 7, 2017

Thanks, Mark

i have put the code and it shows popup message "NO recipients selected!!!"
but immediately after that it throws below run-time error

'2147467259(80004005)':
There must be at least one name or contact group in the To, Cc, or Bcc box.

Cronk · Dec 7, 2017

If you comment out the line

Code:

.Send

and insert the line

Code:

.Display

it will show the generated email on the screen.

The error message is consistent with no records being selected ie no records with
Mail.chk = true
or any records that are marked true do not contain an entry in the email address field.

Mark_ · Dec 7, 2017

IIRC, you could code it as

Code:

IF asEmail = "" then 
   MsgBox "NO recipients selected!!!"
   Exit Sub 'Exit the sub routine.
End If

lookforsmt · Dec 8, 2017

Thanks Cronk, Mark for your valuable suggestions.

i am going with Mark suggestion as i don't want the user to send it anyone else except if listed. Since i will Not be giving the edit rights to table Mail to everyone.
I thank you all

I am working on now capturing more info on the body of the mail, will update in my next post

lookforsmt · Dec 8, 2017

hi! i have found the below code which works well for sending snapshot.
How can i include this code along with my previous code where i am attaching files. This will be combination of snapshot and attachment.

So i don't need to send separate emails to the same recipients, one as snapshot and second as attachment.

Code:

Public Function htmlReportEmail(strTblQryName As String)
    Dim olApp As Outlook.Application
    Dim objMail As Outlook.MailItem
    Dim strMsg As String
    Dim sqlString As String
    Dim sqlString1 As String

    Dim i As Integer
    Dim rowColor As String
    Dim strGreeting As String
    Dim strGreeting1 As String
    Dim rs As ADODB.Recordset
    
    Set rs = New ADODB.Recordset
    
    strGreeting = "Dear All, " & vbNewLine & vbCrLf & "Below is the summary of returns and dispatched" & vbNewLine

    sqlString = "SELECT * From q_Tab_2222"

    rs.Open sqlString, CurrentProject.Connection, adOpenKeyset, adLockOptimistic

    strMsg = "<table border='1' cellpadding='3' cellspacing='3' style='border-collapse: collapse' bordercolor='#111111' width='800'>" & _
        "<tr>" & _
        "<td bgcolor='#7EA7CC'> <b>Entry_Date</b></td>" & _
        "<td bgcolor='#7EA7CC'> <b>VIP_flag</b></td>" & _
        "<td bgcolor='#7EA7CC'> <b>LocationA</b></td>" & _
        "<td bgcolor='#7EA7CC'> <b>LocationB</b></td>" & _
        "<td bgcolor='#7EA7CC'> <b>LocationC</b></td>" & _
        "<td bgcolor='#7EA7CC'> <b>LocationD</b></td>" & _
        "<td bgcolor='#7EA7CC'> <b>LocationE</b></td>" & _
        "<td bgcolor='#7EA7CC'> <b>LocationF</b></td>" & _
        "<td bgcolor='#7EA7CC'> <b>Total</b></td>" & _
        "</tr>"
    i = 0
        Do While Not rs.EOF

    If (i Mod 2 = 0) Then
        rowColor = "<td align=center bgcolor='#FFFFFF'> "
    Else
        rowColor = "<td align=center bgcolor='#E1DFDF'> "
    End If

    strMsg = strMsg & "<tr>" & _
        rowColor & Nz(rs.Fields("Entry_Date"), "") & "</td>" & _
        rowColor & Nz(rs.Fields("VIP_flag"), "") & "</td>" & _
        rowColor & Nz(rs.Fields("LocationA"), "") & "</td>" & _
        rowColor & Nz(rs.Fields("LocationB"), "") & "</td>" & _
        rowColor & Nz(rs.Fields("LocationC"), "") & "</td>" & _
        rowColor & Nz(rs.Fields("LocationD"), "") & "</td>" & _
        rowColor & Nz(rs.Fields("LocationE"), "") & "</td>" & _
        rowColor & Nz(rs.Fields("LocationF"), "") & "</td>" & _
        rowColor & Nz(rs.Fields("Total"), "") & "</td>" & _
        "</tr>"

    rs.MoveNext
    i = i + 1
    Loop

    strMsg = strMsg & "</table>"

    Set olApp = Outlook.Application
    Set objMail = olApp.CreateItem(olMailItem)

    With objMail
        .BodyFormat = olFormatHTML
        .HTMLBody = strGreeting & strMsg
        '.Body = "This is the body of the message." & vbCrLf & vbCrLf

        .Recipients.Add "user1@email.com;user2@email.com"
        .Subject = "Summary Report for date"
        '.Send          'if you want to send it directly without displaying on screen
        .Display        'if you want to display before sending
    End With

    Set olApp = Nothing
    Set objMail = Nothing

End Function

any suggestions

pbaldy · Dec 8, 2017

Disregard the emailing parts, include the parts building strMsg in your earlier code and then use strMsg for the body instead of:

.HTMLBody = "Report"

lookforsmt · Dec 8, 2017

Sorrry, pbaldy. I am not sure how to start and which code to delete. I might mess with the code

pbaldy · Dec 8, 2017

Make a copy of the db and play with it. Copy the parts of the last code building the message to your working email code earlier. Don't copy anything to do with the email, other than the line that sets the body to your string.

lookforsmt · Dec 10, 2017

HI! pbaldy

i tired doing some change in the code to get attacment + body message. Pls see the below code and correct me what i am doing wrong. I am getting pop up message "NO receipients selected"

Code:

Private Sub cmdMail_3bd_Click()

    Dim mess_body As String, strFile As String, strPath As String
    Dim appOutLook As Object
    Dim MailOutLook As Object
    Dim rs As Recordset
    Dim asEmail As String
    Dim Yes As String
'--------------------------------
'    Dim olApp As Outlook.Application
'    Dim objMail As Outlook.MailItem
    Dim strMsg As String
    Dim sqlString As String
    Dim i As Integer
    Dim rowColor As String
    Dim strGreeting As String
    
    Set appOutLook = CreateObject("Outlook.Application")
    Set MailOutLook = appOutLook.CreateItem(0)

    Set rs = CurrentDb.OpenRecordset("Select * from Mail where Mail.Summary_chk=Yes")
       
strMsg = "<table border='1' cellpadding='3' cellspacing='3' style='border-collapse: collapse' bordercolor='#111111' width='800'>" & _
"<tr>" & _
"<td bgcolor='#7EA7CC'> <b>Entry_Date</b></td>" & _
"<td bgcolor='#7EA7CC'> <b>VIP_flag</b></td>" & _
"<td bgcolor='#7EA7CC'> <b>Deleted</b></td>" & _
"<td bgcolor='#7EA7CC'> <b>Received</b></td>" & _
"<td bgcolor='#7EA7CC'> <b>Rejected</b></td>" & _
"<td bgcolor='#7EA7CC'> <b>Returned</b></td>" & _
"<td bgcolor='#7EA7CC'> <b>Total</b></td>" & _
"</tr>"
i = 0

Do While Not rs.EOF

If (i Mod 2 = 0) Then
rowColor = "<td align=center bgcolor='#FFFFFF'> "
Else
rowColor = "<td align=center bgcolor='#E1DFDF'> "
End If

'    strMsg = strMsg & "<tr>" & _
'    rowColor & Nz(rs.Fields("Entry_Date"), "") & "</td>" & _
'    rowColor & Nz(rs.Fields("VIP_flag"), "") & "</td>" & _
'    rowColor & Nz(rs.Fields("Deleted"), "") & "</td>" & _
'    rowColor & Nz(rs.Fields("Received"), "") & "</td>" & _
'    rowColor & Nz(rs.Fields("Rejected"), "") & "</td>" & _
'    rowColor & Nz(rs.Fields("Returned"), "") & "</td>" & _
'    rowColor & Nz(rs.Fields("Total"), "") & "</td>" & _
[    "</tr>"

rs.MoveNext
i = i + 1
Loop

strMsg = strMsg & "</table>"
       
    '~~> Change path here
    strPath = "E:\Test Folder1\Reports\"

    With MailOutLook
    asEmail = ""
         Do While Not rs.EOF
            asEmail = asEmail & rs.Fields("email_ID").Value & "; "
            rs.MoveNext
        Loop
            .To = asEmail
    If asEmail = "" Then
            MsgBox "NO recipients selected!!!"
        Exit Sub 'Exit the sub routine.
    End If

            .Subject = "Report"
 '           .HTMLBody = "Report"
'----------------------------------------------------------------------
        .HTMLBody = "Thank you for Booking. Please find attached." & vbNewLine & vbNewLine & _
    "Booking Confirmation," & vbNewLine & _
    "Terms and Conditions" & vbNewLine & vbNewLine & _
    "If you have any queries regarding this booking, please get in touch." & vbNewLine & vbNewLine & _
    "Many thanks" & vbNewLine & vbNewLine & _
    "Louise"
'---------------------------------------------------------------------
        '~~> *.* for all files
        strFile = Dir(strPath & "*.*")

        Do While Len(strFile) > 0
            .Attachments.Add strPath & strFile
        strFile = Dir
        Loop
    
            '.DeleteAfterSubmit = True
            '.Display
            .Send
    End With
            MsgBox "Reports have been sent", vbOKOnly
End Sub

pbaldy · Dec 10, 2017

You're using the same recordset for the body and the addresses. Is that appropriate? If so, build the address string in the first loop. As you have it, the first loop has already moved the recordset to EOF, so the second loop never runs. You could move it back to the beginning, but might as well do them together.

recipients multiple emails from table

Registered User.

Wino Moderator

Registered User.

Longboard on the internet

Wino Moderator

Registered User.

Attachments

Wino Moderator

Registered User.

Wino Moderator

Longboard on the internet

Registered User.

Registered User.

Longboard on the internet

Registered User.

Registered User.

Wino Moderator

Registered User.

Wino Moderator

Registered User.

Wino Moderator

Similar threads

Users who are viewing this thread