Emails multiple lines from query to 1 recipient (1 Viewer)

abenny

New member
Local time
Today, 03:29
Joined
Oct 24, 2016
Messages
7
Email multiple lines from query to 1 recipient

I have some VBA that pulls in a query and sends an email to the requestor.
I would like that same coding to loop through the query data to send multiple lines to one email recipient. Meaning 1 person could submit multiple invoice lines so in the body of the email I would like the multiple invoice numbers listed out per recipient. See coding below.
Currently for each invoice submitted the employee receives multiple emails

Code:
Public Sub SendMail()
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim strSubject As String
Dim strEmailAddress As String
Dim strEMailMsg As String
Dim ingCounter As Integer
Dim intCount As Integer
Dim aOutlook As Object
Dim aEmail As Object


Set dbs = CurrentDb
Set rst = dbs.OpenRecordset("Email")
'Count of unsent e-mails
intCount = DCount("[ID]", "[PRF]" _
, "[Notified]=0")
'If count of unsent e-mails is zero then the procedure will not run
'If count of unsent e-mails is greater than zero, msgbox will prompt
'to send mail.
If intCount = 0 Then
MsgBox ("You have " & intCount & " emails to send.") _
, vbInformation, "Posted PRF"
Exit Sub
Else

rst.MoveFirst
Do Until rst.EOF
Set aOutlook = CreateObject("Outlook.Application")
Set aEmail = aOutlook.CreateItem(0)

With aEmail
.Display
End With
signature = aEmail.Body
aEmail.Subject = "Posted payment Request"
strEmailAddress = rst![EmployeeEmail]
aEmail.Body = "Invoice Number: " & rst![Invoice Number] & "" & " - " & "Vendor Name: " & rst![Vendor Name] & vbNewLine & signature
aEmail.To = strEmailAddress

aEmail.Send

rst.MoveNext
Loop
rst.Close
Set rst = Nothing
dbs.Close
Set dbs = Nothing
'
'Run update to update the sent mail check box
DoCmd.SetWarnings False
DoCmd.RunSQL "UPDATE PRF SET PRF.Notified = -1 WHERE (((PRF.Notified)=0))"
DoCmd.SetWarnings True
MsgBox "All new Emails have been sent for posted PRF", vbInformation, "Thank You"
End If
 
Last edited:

sneuberg

AWF VIP
Local time
Today, 01:29
Joined
Oct 17, 2014
Messages
3,506
You could sort the source query of the recordset by EmployeeEmail which would group all like email addresses together. Then add a loop inside the current loop that builds up the message of the email as long as the EmployeeEmail is the same.

For future post please enclose code within code tags to preserve indentation. To do this you need to click on the Advanced button, select the code, and click on the pound sign (#).
 

abenny

New member
Local time
Today, 03:29
Joined
Oct 24, 2016
Messages
7
Can I get an example?
 

abenny

New member
Local time
Today, 03:29
Joined
Oct 24, 2016
Messages
7
I put another loop into it but it's giving me the same line for each invoice record. It's not moving to the next record.
The results are still multiple emails with the same invoice line in the body of the email

Code:
 rst.MoveFirst
 Do Until rst.EOF
 Set aOutlook = CreateObject("Outlook.Application")
Set aEmail = aOutlook.CreateItem(0)
 strEmailAddress = rst![EmployeeEmail]
    aEmail.To = strEmailAddress
 rst1.MoveFirst
Do Until rst1.EOF
 
    With aEmail
    .Display
    End With
        signature = aEmail.Body
    aEmail.Subject = "Posted payment Request"
    strEmailAddress = rst![EmployeeEmail]
    aEmail.To = strEmailAddress
rst1.MoveNext
    aEmail.Body = "Invoice Number: " & rst![Invoice Number] & "" & " - " & "Vendor Name: " & rst![Vendor Name] & _
    vbNewLine & signature
rst1.MoveNext
 Loop
    aEmail.Send
 rst.MoveNext
 
Loop
 

sneuberg

AWF VIP
Local time
Today, 01:29
Joined
Oct 17, 2014
Messages
3,506
The inner loop would not be based on the rst1.EOF but something like

Code:
rst![EmployeeEmail] <> strEmailAddress

the trick is to know where to put it and where to update strEmailAddress. I'd just think through the variations
Code:
Do Until rst![EmployeeEmail] <> strEmailAddress

or
Code:
Do While rst![EmployeeEmail] =strEmailAddress

on paper until you see that it does what you want. I'd help more but I'm tired and I'm getting a headache.
 

abenny

New member
Local time
Today, 03:29
Joined
Oct 24, 2016
Messages
7
I have it working but when it gets to the last record to populate in the body of the email I get an error 'No Current record'. It does not send the email or populate the last invoice line in the body. I am missing something to do with the recordset but am drawing a blank.

Code:
Public Sub SendMail()
 Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim strSubject As String
Dim strEmailAddress As String
Dim strEMailMsg As String
Dim ingCounter As Integer
Dim intCount As Integer
Dim aOutlook As Object
Dim aEmail As Object
Dim mySQL As String
 
Set dbs = CurrentDb
Set rst = dbs.OpenRecordset("Email")
'Set rst1 = dbs.OpenRecordset("Email")
 'Count of unsent e-mails
intCount = DCount("[ID]", "[PRF]" _
, "[Notified]=0")
'If count of unsent e-mails is zero then the procedure will not run
'If count of unsent e-mails is greater than zero, msgbox will prompt
'to send mail.
     If intCount = 0 Then
        MsgBox ("You have " & intCount & " emails to send.") _
        , vbInformation, "Posted PRF"
        Exit Sub
    Else
 
rst.MoveLast
rst.MoveFirst
 Do Until rst.EOF
 Set aOutlook = CreateObject("Outlook.Application")
Set aEmail = aOutlook.CreateItem(0)
 strEmailAddress = rst![EmployeeEmail]
    aEmail.To = strEmailAddress
 Do While rst![EmployeeEmail] = strEmailAddress
     With aEmail
    .Display
    End With
        signature = aEmail.Body
    aEmail.Subject = "Posted payment Request"
'    strEmailAddress = rst![EmployeeEmail]
'    aEmail.To = strEmailAddress
    aEmail.Body = "Invoice Number: " & rst![Invoice Number] & "" & " - " & "Vendor Name: " & rst![Vendor Name] & _
    vbNewLine & signature
 rst.MoveNext - ----------------Error Occurs
Loop
     aEmail.Send
 rst.MoveNext
 Loop
 End If
rst.Close
Set rst = Nothing
dbs.Close
Set dbs = Nothing
'
'Run update to update the sent mail check box
    DoCmd.SetWarnings False
    DoCmd.RunSQL "UPDATE PRF SET PRF.Notified = -1 WHERE (((PRF.Notified)=0))"
    DoCmd.SetWarnings True
    MsgBox "All new emails have been sent for posted PRF", vbInformation, "Thank You"
End If
End Sub
 

Frothingslosh

Premier Pale Stale Ale
Local time
Today, 04:29
Joined
Oct 17, 2012
Messages
3,276
Proper indentation helps immensely.

Code:
Public Sub SendMail()
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim strSubject As String
Dim strEmailAddress As String
Dim strEMailMsg As String
Dim ingCounter As Integer
Dim intCount As Integer
Dim aOutlook As Object
Dim aEmail As Object
Dim mySQL As String
 
Set dbs = CurrentDb
    Set rst = dbs.OpenRecordset("Email")
    'Set rst1 = dbs.OpenRecordset("Email")
    'Count of unsent e-mails
    intCount = DCount("[ID]", "[PRF]" _
    , "[Notified]=0")
    'If count of unsent e-mails is zero then the procedure will not run
    'If count of unsent e-mails is greater than zero, msgbox will prompt
    'to send mail.
    
    If intCount = 0 Then
        MsgBox ("You have " & intCount & " emails to send.") _
        , vbInformation, "Posted PRF"
        Exit Sub
    Else
        rst.MoveLast
        rst.MoveFirst
        Do Until rst.EOF
            Set aOutlook = CreateObject("Outlook.Application")
            Set aEmail = aOutlook.CreateItem(0)
            strEmailAddress = rst![EmployeeEmail]
            aEmail.To = strEmailAddress
            Do While rst![EmployeeEmail] = strEmailAddress
                With aEmail
                    .Display
                End With
                Signature = aEmail.Body
                aEmail.Subject = "Posted payment Request"
                '    strEmailAddress = rst![EmployeeEmail]
                '    aEmail.To = strEmailAddress
                aEmail.Body = "Invoice Number: " & rst![Invoice Number] & "" & " - " & "Vendor Name: " & rst![Vendor Name] & _
                vbNewLine & Signature
                rst.MoveNext '- ----------------Error Occurs
            Loop
            aEmail.Send
            rst.MoveNext
        Loop
    End If
    rst.Close
    Set rst = Nothing
    dbs.Close
    Set dbs = Nothing
    '
    'Run update to update the sent mail check box
    DoCmd.SetWarnings False
    DoCmd.RunSQL "UPDATE PRF SET PRF.Notified = -1 WHERE (((PRF.Notified)=0))"
    DoCmd.SetWarnings True
    MsgBox "All new emails have been sent for posted PRF", vbInformation, "Thank You"
    End If
End Sub

What's happening is your inner loop runs until EmployeeEmail no longer matches strEmailAddress. If you reach the end of the recordset with that true, your next .MoveNext will generate the error you're seeing.
 

MarkK

bit cruncher
Local time
Today, 01:29
Joined
Mar 17, 2004
Messages
8,178
My 2c when writing code like this is use subroutines. For instance, it looks like you are trying to concatenate data about multiple invoices into a single string to send to a single recipient.

So, write a Function that receives the ID in question, and returns the string you need. Don't worry about opening Outlook. Don't worry about the multiple recipient part. Write the parts separately. Test them with sample data separately. Then bring them together when each small simple part works as expected.

You are getting your different tasks confused. Notice here how you create a new instance of Outlook for every email, obviously not a good idea...
Code:
        Do Until rst.EOF
            Set aOutlook = CreateObject("Outlook.Application")
            Set aEmail = aOutlook.CreateItem(0)
...but an easy mistake to make if all your many tasks are combined in a single subroutine.

Hope this helps,
 

MarkK

bit cruncher
Local time
Today, 01:29
Joined
Mar 17, 2004
Messages
8,178
You mean me? Do you mean apart from what I suggested?
...write a Function that receives the ID in question, and returns the string you need.
 

janeyg

Registered User.
Local time
Today, 08:29
Joined
May 11, 2012
Messages
90
Hi

I know this is an old thread but I am trying to achieve a similar task and I too am struggling. I get a Run-Time Error '3021' No Current Record Found

I know there is an issue with the Loop but I am stuck - can anyone help me with this code?


Private Sub TestEmail_Click()

Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim strSubject As String
Dim strEmailAddress As String
Dim strEMailMsg As String
Dim ingCounter As Integer
Dim intCount As Integer
Dim aOutlook As Object
Dim aEmail As Object
Dim mySQL As String
Dim outApp As Outlook.Application
Dim outMail As Outlook.MailItem
Dim outlookStarted As Boolean

Set dbs = CurrentDb
Set rst = dbs.OpenRecordset("QRYFirstEmail2")
'Set rst1 = dbs.OpenRecordset("QRYFirstEmail2")

Do Until rst.EOF
Set aOutlook = CreateObject("Outlook.Application")
Set aEmail = aOutlook.CreateItem(0)
strEmailAddress = rst![EmailAddress]
aEmail.To = strEmailAddress

Do While rst![EmailAddress] = strEmailAddress
With aEmail
.Display
End With
Signature = aEmail.Body
aEmail.Subject = "Module Lists to complete"
' strEmailAddress = rst![EmployeeEmail]
' aEmail.To = strEmailAddress
aEmail.Body = "Module Code: " & rst![ModuleCode] & "" & " - " & "Module Title: " & rst![ModuleTitle] & _
vbNewLine & Signature
rst.MoveNext
Loop
rst.MoveNext
aEmail.Send

'Code Stops here, email stops before completing

Loop
rst.MoveNext



MsgBox "All new emails have been sent", vbInformation, "Thank You"


rst.Close
Set rst = Nothing
dbs.Close
Set dbs = Nothing

End Sub
 

Frothingslosh

Premier Pale Stale Ale
Local time
Today, 04:29
Joined
Oct 17, 2012
Messages
3,276
As I told the previous poster, proper indentation helps a LOT.

Code:
Private Sub TestEmail_Click()
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim strSubject As String
Dim strEmailAddress As String
Dim strEMailMsg As String
Dim ingCounter As Integer
Dim intCount As Integer
Dim aOutlook As Object
Dim aEmail As Object
Dim mySQL As String
Dim outApp As Outlook.Application
Dim outMail As Outlook.MailItem
Dim outlookStarted As Boolean

Set dbs = CurrentDb
Set rst = dbs.OpenRecordset("QRYFirstEmail2")
'Set rst1 = dbs.OpenRecordset("QRYFirstEmail2")

    Do Until rst.EOF
        Set aOutlook = CreateObject("Outlook.Application")
        Set aEmail = aOutlook.CreateItem(0)
        strEmailAddress = rst![EmailAddress]
        aEmail.To = strEmailAddress
        
        Do While rst![EmailAddress] = strEmailAddress
            With aEmail
            .Display
            End With
            Signature = aEmail.Body
            aEmail.Subject = "Module Lists to complete"
            ' strEmailAddress = rst![EmployeeEmail]
            ' aEmail.To = strEmailAddress
            aEmail.Body = "Module Code: " & rst![ModuleCode] & "" & " - " & "Module Title: " & rst![ModuleTitle] & _
            vbNewLine & Signature
            rst.MoveNext
        Loop
        rst.MoveNext
        aEmail.Send
        
        'Code Stops here, email stops before completing
    
    Loop
    rst.MoveNext
    MsgBox "All new emails have been sent", vbInformation, "Thank You"

    rst.Close
    Set rst = Nothing
    dbs.Close
    Set dbs = Nothing
End Sub
Now, that said, you have a few issues.

First, the 'no current record found': You're having EXACTLY the same issue the OP did: your inner loop runs until rst!EmailAddress doesn't match strEmailAddress. Any time you have a situation where all records' emails match your variable, you'll loop until you run out of records, then you'll .MoveNext again and get the error.

Instead, loop until .EOF, and then add this as the very first line inside the loop:
Code:
If rst!EmailAddress <> strEmailAddress Then Exit For
That will return you to the outer loop immediately.

Second, you have an infinite loop going, because your rst.MoveNext is OUTSIDE the outer loop. You need to put it BEFORE that last Loop, not after. :)

Finally, these errors actually saved you from a THIRD error. Calling dbs.Close when dbs is the active database will actually close out the application.

Edit: I just noticed you have another issue: in both versions, it's quite possible to move to a record via the inner loop, then exit the loop and immediately move to the next record AGAIN, skipping a record. I typically handle that with a tracking variable, maybe something like 'bolMoved' as a Boolean. Set it to False at the start of the outer loop, set it to True either right before or right after the MoveNext in the INNER loop, then only execute the MoveNext in the OUTER loop if bolMoved is FALSE.
 
Last edited:

janeyg

Registered User.
Local time
Today, 08:29
Joined
May 11, 2012
Messages
90
Hi Frothingslosh

I really appreciate your help but confess to making a terrible mess of this as I keep getting an error on part of the If that I added "Compile Error Exit For not within For..Next. Have I misunderstood where to put these elements?

Code:
Private Sub TestEmail_Click()

Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim strSubject As String
Dim strEmailAddress As String
Dim strEMailMsg As String
Dim ingCounter As Integer
Dim intCount As Integer
Dim aOutlook As Object
Dim aEmail As Object
Dim mySQL As String
Dim outApp As Outlook.Application
Dim outMail As Outlook.MailItem
Dim outlookStarted As Boolean
 
Set dbs = CurrentDb
    Set rst = dbs.OpenRecordset("QRYFirstEmail2")
    'Set rst1 = dbs.OpenRecordset("QRYFirstEmail2")
 
        Do Until rst.EOF
            
            Set aOutlook = CreateObject("Outlook.Application")
            Set aEmail = aOutlook.CreateItem(0)
            strEmailAddress = rst![EmailAddress]
            aEmail.To = strEmailAddress
            
            Do While rst![EmailAddress] <> strEmailAddress
                
                With aEmail
                    .Display
                End With
                Signature = aEmail.Body
                aEmail.Subject = "Module Lists to complete"
                '    strEmailAddress = rst![EmployeeEmail]
                '    aEmail.To = strEmailAddress
                aEmail.Body = "Module Code: " & rst![ModuleCode] & "" & " - " & "Module Title: " & rst![ModuleTitle] & _
                vbNewLine & Signature
                rst.MoveNext
                bolMoved = True
                
            Loop
            
                If rst![COLOR="Red"][EmailAddress] [/COLOR]<> strEmailAddress Then Exit For
                rst.MoveNext
                aEmail.Send
                
                
                MsgBox "All new emails have been sent", vbInformation, "Thank You"

                
                rst.MoveNext
            
           
            Loop
            
                bolMoved = False
                
       
            MsgBox "All new emails have been sent", vbInformation, "Thank You"
        
 
    rst.Close
    Set rst = Nothing
    dbs.Close
    Set dbs = Nothing
    

    End Sub
 

Frothingslosh

Premier Pale Stale Ale
Local time
Today, 04:29
Joined
Oct 17, 2012
Messages
3,276
That was my error; it should be Exit Do, not Exit For. Wrong loop! :eek:

That said, you have it in the wrong spot. It should be the first line in the inner loop, right before 'With aEmail'.

Where you currently have the conditional exit is where you would put the variable I mentioned to track whether or not you've already moved to a new record.

Another error I spotted is that you're opening outlook once for each loop - just do it once, THEN loop.

Code:
Private Sub TestEmail_Click()
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim strSubject As String
Dim strEmailAddress As String
Dim strEMailMsg As String
Dim ingCounter As Integer
Dim intCount As Integer
Dim aOutlook As Object
Dim aEmail As Object
Dim mySQL As String
Dim outApp As Outlook.Application
Dim outMail As Outlook.MailItem
Dim outlookStarted As Boolean
Dim bolMoved As Boolean

    Set dbs = CurrentDb

    Set rst = dbs.OpenRecordset("QRYFirstEmail2")
    'Set rst1 = dbs.OpenRecordset("QRYFirstEmail2")
 
    Do Until rst.EOF
    
        bolMoved = False
        Set aOutlook = CreateObject("Outlook.Application")
        Set aEmail = aOutlook.CreateItem(0)
        strEmailAddress = rst![EmailAddress]
        aEmail.To = strEmailAddress
        
        Do While rst![EmailAddress] <> strEmailAddress
            
            If rst![EmailAddress] <> strEmailAddress Then Exit Do
            
            With aEmail
                .Display
            End With
            Signature = aEmail.Body
            aEmail.Subject = "Module Lists to complete"
            '    strEmailAddress = rst![EmployeeEmail]
            '    aEmail.To = strEmailAddress
            aEmail.Body = "Module Code: " & rst![ModuleCode] & "" & " - " & "Module Title: " & rst![ModuleTitle] & _
                           vbNewLine & Signature
            rst.MoveNext
            bolMoved = True
            
        Loop
        
        aEmail.Send
        If Not bolMoved Then rst.MoveNext
       
    Loop
            
    MsgBox "All new emails have been sent", vbInformation, "Thank You"
        
 
    rst.Close
    Set rst = Nothing
    dbs.Close   'LOSE THIS OR IT WILL CLOSE YOUR APPLICATION RIGHT THEN AND THERE
    Set dbs = Nothing
    
End Sub
I would still recommend checking your logic - the way this is written, if you have more than one record for the same email address, you're just overwriting the subject and body each time, then sending the single email. Not sure a loop is actually needed in that situation. Are you sure that interior loop shouldn't be an IF/THEN construct instead?
 
Last edited:

MarkK

bit cruncher
Local time
Today, 01:29
Joined
Mar 17, 2004
Messages
8,178
From what I can see, the declared variables I've commented out are not in use in that code block...
Code:
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
[COLOR="Green"]'Dim strSubject As String
[/COLOR]Dim strEmailAddress As String
[COLOR="green"]'Dim strEMailMsg As String
'Dim ingCounter As Integer
'Dim intCount As Integer
[/COLOR]Dim aOutlook As Object
Dim aEmail As Object
[COLOR="green"]'Dim mySQL As String
'Dim outApp As Outlook.Application
'Dim outMail As Outlook.MailItem
'Dim outlookStarted As Boolean
[/COLOR]Dim bolMoved As Boolean
Mark
 

Frothingslosh

Premier Pale Stale Ale
Local time
Today, 04:29
Joined
Oct 17, 2012
Messages
3,276
He's also opening Outlook once per email, just like the OP did. I forgot to mention that in my last post, as well.
 

MarkK

bit cruncher
Local time
Today, 01:29
Joined
Mar 17, 2004
Messages
8,178
Hey frothy, :)
And, I would use subroutines. As previously mentioned.
Mark
 

Frothingslosh

Premier Pale Stale Ale
Local time
Today, 04:29
Joined
Oct 17, 2012
Messages
3,276
Oh, so would I. I just figured I have enough fights going here, and I am honestly entirely too busy to be going down that rabbit hole today. :p

I came here to post mainly to get a rest from dealing with my current project snag at work.
 

janeyg

Registered User.
Local time
Today, 08:29
Joined
May 11, 2012
Messages
90
Hi Mark, Frothingslosh

Many thanks for your replies I really appreciate you taking the time to help, you are both so right. I need to rethink code as now this is sending separate blank emails :(

I can't seem to find anyone who has cracked how to achieve this.

I'll take on board all you advice and rethink the code , including opening outlook per email.

Its a big learning curve for me.
Many thanks
Jane
 

Frothingslosh

Premier Pale Stale Ale
Local time
Today, 04:29
Joined
Oct 17, 2012
Messages
3,276
You're already opening outlook once per email; that's part of your problem.

I'll try to whip up something a bit more efficient, but it'll take time. Basically, I'll be doing it while running some time-consuming queries for reports and during lunch, so don't expect a solution right away unless someone else swoops in with one.
 

Users who are viewing this thread

Top Bottom