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

janeyg · Feb 22, 2018

I would really appreciate your help on this Frothingslosh

Frothingslosh · Feb 23, 2018

Okay, for the record, this is air code - I haven't had time to test it. If it works perfectly, great, we got lucky. If it doesn't and you can't get it debugged, I'll take a look at it after work.

That said, it's a wee bit more complex than you may have been expecting, so make DAMNED well sure you understand everything that's being done, and make sure to read the comments I put in. If you don't understand something, ASK.

This is a full module - if you're adding it to an existing one, make sure to place the ENUM declaration at the top of the existing one.

Code:

Option Compare Database
Option Explicit
Private Enum InitialWindowState
    wsMaximized = 0
    wsMinimized = 1
    wsNormalWindow = 2
End Enum
Public Sub SendNotices()
Dim OutlookApp As Object
'Dim OutlookApp As Outlook.Application
Dim rs As DAO.Recordset
Dim EmailTo As String
Dim EmailBody As String
Dim EmailSignature As String
Dim EmailSubject As String
Dim MovedToNext As Boolean
Const EMAIL_ITEM = 0
'Error handler currently turned off for debugging.
'On Error GoTo ErrHandler
    Set rs = CurrentDb.OpenRecordset("QRYFirstEmail2")
    
    'This loop is built assuming that you want one email sent per email address.
    'If you want one email per record, instead, then this needs to be re-worked.
    If Not rs.EOF Then
        Set OutlookApp = GetOutlook(wsMinimized)
        
        If Not OutlookApp Is Nothing Then
        
            EmailSubject = "Module Lists to Complete"
            
            Do
                EmailTo = rs!Emailaddress
                EmailBody = BuildBody(rs, EmailTo)  'NOTE: MoveNext IS PERFORMED HERE!!!
                Call SendEmail(EmailTo, EmailBody, EmailSubject, EmailSignature, OutlookApp)
            'There is no .MoveNext because that happens as part of BuildBody above.
            Loop Until rs.EOF
            
            MsgBox "All new emails have been sent", vbInformation, "Thank You"
            
        End If
    End If
ProcExit:
    If Not rs Is Nothing Then
        rs.Close
        Set rs = Nothing
    End If
    Exit Sub
    
ErrHandler:
    Beep
    MsgBox "Error Number:" & vbTab & Err.Number & vbCrLf & vbCrLf & _
           "Error Description:" & vbCrLf & Err.Description
    Resume ProcExit
    
End Sub
Private Function BuildBody(ByRef rs As DAO.Recordset, _
                           ByVal EmailTo As String) As String
'Are you sure this format is what you want?  It's going to look something like this:
'**********************************************************************************
'***     ModuleCode:                                                            ***
'***     For x = 1 To 23                                                        ***
'***         DoCmd.stuff                                                        ***
'***         DoCmd.morestuff                                                    ***
'***         Call SomeRandomSub                                                 ***
'***         CurrentDb.Execute "SomeUpdateQuery", dbSeeChanges + dbFailOnError  ***
'***     Next x - ModuleTitle: SomeModuleName                                   ***
'***     ModuleCode:                                                            ***
'***     Do                                                                     ***
'***         DoCmd.evenmorestuff                                                ***
'***         DoCmd.randomstuff                                                  ***
'***         Call SomeRandomSub                                                 ***
'***         CurrentDb.Execute "SomeUpdateQuery", dbSeeChanges + dbFailOnError  ***
'***     Loop Until SomeLogicalTest - ModuleTitle: SomeModuleName               ***
'**********************************************************************************
    Do Until rs!Emailaddress <> EmailTo
        BuildBody = "Module Code: " & rs!ModuleCode & "Module Title: " & rs!ModuleTitle & vbCrLf
        rs.MoveNext
        If rs.EOF Then Exit Do
    Loop
    
End Function
Private Function GetOutlook(Optional WindowState As InitialWindowState = wsMinimized) As Object
'Dim O As Outlook.Application
Dim O As Object
Const FOLDER_INBOX = 6
On Error GoTo ErrHandler
    Set O = GetObject(, "Outlook.Application")
    If O.Explorers.Count = 0 Then
InitOutlook:
        O.Session.GetDefaultFolder(FOLDER_INBOX).Display
        O.ActiveExplorer.WindowState = WindowState
    End If
    Set GetOutlook = O
    
ProcExit:
    Set O = Nothing
    Exit Function
ErrHandler:
    Select Case Err.Number
        Case -2147352567
            'User cancelled setup, silently exit
            Set O = Nothing
        Case 429, 462
            Set O = GetOutlookApp()
            If O Is Nothing Then
                Err.Raise 429, "OutlookApp", "Outlook Application does not appear to be installed."
            Else
                Resume InitOutlook
            End If
        Case Else
            Beep
            MsgBox "Error Number:" & vbTab & Err.Number & vbCrLf & vbCrLf & _
                   "Error Description:" & vbCrLf & Err.Description
    End Select
    Resume ProcExit
End Function
Private Function GetOutlookApp() As Object
On Error GoTo ErrHandler
    Set GetOutlookApp = CreateObject("Outlook.Application")
    
ProcExit:
    Exit Function
    
ErrHandler:
    Set GetOutlookApp = Nothing
    Resume ProcExit
    
End Function
Private Sub SendEmail(ByVal EmailTo As String, _
                      ByVal EmailBody As String, _
                      ByRef EmailSubject As String, _
                      ByVal EmailSignature As String, _
                      ByRef OutlookApp As Object)
'EmailSubject is ByRef so it can be permanently modified.
'Dim EmailItem As Outlook.MailItem
Dim EmailItem As Object
Const EMAIL_ITEM = 0
    Set EmailItem = OutlookApp.CreateItem(EMAIL_ITEM)
    If EmailSignature = "" Then EmailSignature = EmailItem.Body
    
    With EmailItem
        .To = EmailTo
        .Subject = EmailSubject
        .Body = EmailBody & vbCrLf & EmailSignature
        .Send
    End With
    
End Sub

janeyg · Feb 23, 2018

Hi Frothingslosh, wow that's some code - I am going through it and will come back

janeyg · Mar 3, 2018

Hi Frothingslosh

I have been going through this code, must confess - I have never heard of air code before. You are right, this is a complex code. I have pasted the code above into a new module which separates the code. Does this code operate differently? I have a command button on a form - Do I call on each piece of code to test or the whole module?

Many thanks

janeyg · Mar 3, 2018

I really dont know how to apply this code using a command button on a form, I just get errors - could you tell me how Frothingslosh?

Frothingslosh · Mar 3, 2018

You can have the code in a module or in the calling form's code (which is just a module attached to the form).

Have your button run this line:

Code:

Call SendNotices()

If you want to trace through what it's doing, insert the command STOP as the very first line after Public Sub SendNotices(). Then you can step through the code one line at a time with F8 or the step key up on the toolbar. While stepping, you can look at variable values either by hovering the mouse over the variable in the code, or by typing into the Immediate Window (you can open it from the toolbar in the VBA editor if it's not there already) the command Debug.Print followed by the variable you want to see.

For example:

Code:

Debug.Print EmailSignature

The other functions are called by the initial one as needed.

And 'air code' is just slang for 'written but not tested'.

janeyg · Mar 4, 2018

Hi Frothingslosh,

Many thanks for the above. I have now applied this to my command button and successfully calling the module. The email sends but when delivered i see that it has only picked up one record i.e. module title and module code with the first email, it does not pick up the other records with the same email address, though only one email sent is correct the module code and title are missing on the other emails sent. I am not sure why? Do you have any thoughts?
Many thanks
j

janeyg · Mar 5, 2018

Sorry correction, the records with same email address are not added to the email sent - only one record. In my test query I have 4 records with 2 emails but the email only picks up one record - the loop does not seem to pick up the other record with the same email address. I followed the code through and the BuildBody does loop so I dont see why it is not adding the records where the email address matches.

Frothingslosh · Mar 5, 2018

Hint: The problem occurs in BuildBody().

Also, read the comments in BuildBody(), because I'm not sure the format is what you're actually expecting.

Frothingslosh · Mar 5, 2018

Okay, fixed code, tested and working as requested. I'm pretty sure you will need to tweak the formatting in BuildBody, as it's barely readable and in a lousy order, but I built it to match the specs in your original post.

Also, the test database I used is attached; you will, however, need to update the emails. The database is Access 2007 format.

Code:

Option Compare Database
Option Explicit

Private Enum InitialWindowState
    wsMaximized = 0
    wsMinimized = 1
    wsNormalWindow = 2
End Enum

Public Sub SendNotices()

Dim OutlookApp As Object
[COLOR=darkgreen]'Dim OutlookApp As Outlook.Application
[/COLOR]Dim rs As DAO.Recordset
Dim EmailTo As String
Dim EmailBody As String
Dim EmailSignature As String
Dim EmailSubject As String
Dim MovedToNext As Boolean
Const EMAIL_ITEM = 0

On Error GoTo ErrHandler

    Set rs = CurrentDb.OpenRecordset("QRYFirstEmail2")
    
    [COLOR=darkgreen]'This loop is built assuming that you want one email sent per email address.
    'If you want one email per record, instead, then this needs to be re-worked.[/COLOR]
    If Not rs.EOF Then

        Set OutlookApp = GetOutlook(wsMinimized)
        
        If Not OutlookApp Is Nothing Then
        
            EmailSubject = "Module Lists to Complete"
            
            Do
                EmailTo = rs!Emailaddress
                EmailBody = BuildBody(rs, EmailTo)  'NOTE: MoveNext IS PERFORMED HERE!!!
                Call SendEmail(EmailTo, EmailBody, EmailSubject, EmailSignature, OutlookApp)
            [COLOR=darkgreen]'There is no .MoveNext because that happens as part of BuildBody above.[/COLOR]
            Loop Until rs.EOF
            
            MsgBox "All new emails have been sent", vbInformation, "Thank You"
            
        End If
    End If

ProcExit:
    If Not rs Is Nothing Then
        rs.Close
        Set rs = Nothing
    End If
    Exit Sub
    
ErrHandler:
    Beep
    MsgBox "Error Number:" & vbTab & Err.Number & vbCrLf & vbCrLf & _
           "Error Description:" & vbCrLf & Err.Description
    Resume ProcExit
    
End Sub

Private Function BuildBody(ByRef rs As DAO.Recordset, _
                           ByVal EmailTo As String) As String
[COLOR=darkgreen]'Are you sure this format is what you want?  It's going to look something like this:
'**********************************************************************************
'***     ModuleCode:                                                            ***
'***     For x = 1 To 23                                                        ***
'***         DoCmd.stuff                                                        ***
'***         DoCmd.morestuff                                                    ***
'***         Call SomeRandomSub                                                 ***
'***         CurrentDb.Execute "SomeUpdateQuery", dbSeeChanges + dbFailOnError  ***
'***     Next x - ModuleTitle: SomeModuleName                                   ***
'***     ModuleCode:                                                            ***
'***     Do                                                                     ***
'***         DoCmd.evenmorestuff                                                ***
'***         DoCmd.randomstuff                                                  ***
'***         Call SomeRandomSub                                                 ***
'***         CurrentDb.Execute "SomeUpdateQuery", dbSeeChanges + dbFailOnError  ***
'***     Loop Until SomeLogicalTest - ModuleTitle: SomeModuleName               ***
'**********************************************************************************
[/COLOR]    Do Until rs!Emailaddress <> EmailTo
        BuildBody = BuildBody & "Module Code: " & vbCrLf & rs!ModuleCode & " - " & "Module Title: " & rs!ModuleTitle & vbCrLf
        rs.MoveNext
        If rs.EOF Then Exit Do
    Loop
    
End Function

Private Function GetOutlook(Optional WindowState As InitialWindowState = wsMinimized) As Object
[COLOR=darkgreen]'Dim O As Outlook.Application
[/COLOR]Dim O As Object
Const FOLDER_INBOX = 6

On Error GoTo ErrHandler

    Set O = GetObject(, "Outlook.Application")
    If O.Explorers.Count = 0 Then
InitOutlook:
        O.Session.GetDefaultFolder(FOLDER_INBOX).Display
        O.ActiveExplorer.WindowState = WindowState
    End If
    Set GetOutlook = O
    
ProcExit:
    Set O = Nothing
    Exit Function

ErrHandler:
    Select Case Err.Number
        Case -2147352567
            'User cancelled setup, silently exit
            Set O = Nothing
        Case 429, 462
            Set O = GetOutlookApp()
            If O Is Nothing Then
                Err.Raise 429, "OutlookApp", "Outlook Application does not appear to be installed."
            Else
                Resume InitOutlook
            End If
        Case Else
            Beep
            MsgBox "Error Number:" & vbTab & Err.Number & vbCrLf & vbCrLf & _
                   "Error Description:" & vbCrLf & Err.Description
    End Select
    Resume ProcExit
End Function

Private Function GetOutlookApp() As Object

On Error GoTo ErrHandler

    Set GetOutlookApp = CreateObject("Outlook.Application")
    
ProcExit:
    Exit Function
    
ErrHandler:
    Set GetOutlookApp = Nothing
    Resume ProcExit
    
End Function

Private Sub SendEmail(ByVal EmailTo As String, _
                      ByVal EmailBody As String, _
                      ByRef EmailSubject As String, _
                      ByVal EmailSignature As String, _
                      ByRef OutlookApp As Object)
[COLOR=darkgreen]'EmailSubject is ByRef so it can be permanently modified.[/COLOR]

[COLOR=darkgreen]'Dim EmailItem As Outlook.MailItem
[/COLOR]Dim EmailItem As Object
Const EMAIL_ITEM = 0

    Set EmailItem = OutlookApp.CreateItem(EMAIL_ITEM)
    If EmailSignature = "" Then EmailSignature = EmailItem.Body
    
    With EmailItem
        .To = EmailTo
        .Subject = EmailSubject
        .Body = EmailBody & vbCrLf & EmailSignature
        .Send
    End With
    
End Sub

janeyg · Mar 5, 2018

The email looks fine. It has the variable module code and title at the top with the additional letter text I added it just adds only one records where there ar multiple:-

Module Code: AA0126
Module Title: Developing Knowledge and Skills within Adult Nursing Care

Dear Jane,
We have received notification that your module/s listed above has successfully passed through the Programme Framework for xxx Awards approvals process.
This module now requires creation of a Reading List on the University Library's Reading List service.

I looked at the previous code which did loop and add multiple records but then got a 'no current record' error. Also as noted, not the best to open outlook each time. Your code works great except pinpointing what to change. Whatever I try either fails or sends a continuous loop of emails

Frothingslosh · Mar 5, 2018

I think you missed my second post this morning.

janeyg · Mar 5, 2018

I think I did! - Fantastic! I really can't thank you enough for all of your help on this - it works perfectly

Thank you also for attaching the database to - complete life saver

Jane

janeyg · Mar 8, 2018

Hi, is there a way to send the email from another email account/address with this code? All references i find seem to refer to olMail.

Code:

Option Compare Database

Option Explicit
Private Enum InitialWindowState
    wsMaximized = 0
    wsMinimized = 1
    wsNormalWindow = 2
End Enum

Public Sub SendNotices()
Dim OutlookApp As Object
'Dim OutlookApp As Outlook.Application
Dim rs As DAO.Recordset
Dim EmailTo As String
Dim EmailCC As String
Dim EmailBody As String
Dim EmailSignature As String
Dim EmailSubject As String
Dim MovedToNext As Boolean




Const EMAIL_ITEM = 0
'Error handler currently turned off for debugging.
'On Error GoTo ErrHandler
    Set rs = CurrentDb.OpenRecordset("QRYFirstEmail2")
    
    'This loop is built assuming that you want one email sent per email address - This option is correct
    'If you want one email per record, instead, then this needs to be re-worked.
    If Not rs.EOF Then
        Set OutlookApp = GetOutlook(wsMinimized)
        
        
        If Not OutlookApp Is Nothing Then
        
            EmailSubject = "First Email"
            
            'EmailCC = "here@bla.ac.uk
            
            EmailSignature = Trim("Dear " & rs.Fields("FirstName").Value) & "," & vbCrLf & vbCrLf & "We have received notification that your module/s listed above has successfully passed through the approvals process." & vbCrLf & vbCrLf & _
                    "text here." & vbCrLf & "We do not currently have a list on the Reading List service for this module.  We're therefore contacting you to offer our support with getting started with using the service to create your list yourself." & vbCrLf & _
                    "Similarly we also offer refresher training sessions to those academics who have not used the service in a while.  Please contact us so we can set this up." & vbCrLf & _
                    "Please request access to your module list on the service by clicking on the link below and completing the webform:" & _
                    "more text here." & vbCrLf & _
                    "xxxxxtext here." & vbCrLf & _
                    "Kind regards" & vbCrLf & "Reading List team" & vbCrLf
            
            Do
                EmailTo = rs!EmailAddress
                EmailBody = BuildBody(rs, EmailTo)  'NOTE: MoveNext IS PERFORMED HERE!!!
                Call SendEmail(EmailTo, EmailCC, EmailBody, EmailSubject, EmailSignature, OutlookApp)
            'There is no .MoveNext because that happens as part of BuildBody above.
            Loop Until rs.EOF
            
            MsgBox "All new emails have been successfully sent!", vbInformation, "Thank You"
            
                'run query update
        CurrentDb.Execute "QRYFirstEmail2UPDATE"
            
        End If
        
    End If
ProcExit:
    If Not rs Is Nothing Then
        rs.Close
        Set rs = Nothing
    End If
    Exit Sub
    
ErrHandler:
    Beep
    MsgBox "Error Number:" & vbTab & Err.Number & vbCrLf & vbCrLf & _
           "Error Description:" & vbCrLf & Err.Description
    Resume ProcExit
    
End Sub
Private Function BuildBody(ByRef rs As DAO.Recordset, _
                           ByVal EmailTo As String) As String

 Do Until rs!EmailAddress <> EmailTo
        BuildBody = BuildBody & Chr(149) & " " & "Module Code: " & rs!ModuleCode & " - " & "Module Title: " & rs!ModuleTitle & vbCrLf
        rs.MoveNext
        If rs.EOF Then Exit Do
    Loop
    
End Function
Private Function GetOutlook(Optional WindowState As InitialWindowState = wsMinimized) As Object
'Dim O As Outlook.Application
Dim O As Object
Const FOLDER_INBOX = 6
On Error GoTo ErrHandler
    Set O = GetObject(, "Outlook.Application")
    If O.Explorers.Count = 0 Then
InitOutlook:
        O.Session.GetDefaultFolder(FOLDER_INBOX).Display
        O.ActiveExplorer.WindowState = WindowState
    End If
    Set GetOutlook = O
    
ProcExit:
    Set O = Nothing
    Exit Function
ErrHandler:
    Select Case Err.Number
        Case -2147352567
            'User cancelled setup, silently exit
            Set O = Nothing
        Case 429, 462
            Set O = GetOutlookApp()
            If O Is Nothing Then
                Err.Raise 429, "OutlookApp", "Outlook Application does not appear to be installed."
            Else
                Resume InitOutlook
            End If
        Case Else
            Beep
            MsgBox "Error Number:" & vbTab & Err.Number & vbCrLf & vbCrLf & _
                   "Error Description:" & vbCrLf & Err.Description
    End Select
    Resume ProcExit
End Function
Private Function GetOutlookApp() As Object
On Error GoTo ErrHandler
    Set GetOutlookApp = CreateObject("Outlook.Application")
    
ProcExit:
    Exit Function
    
ErrHandler:
    Set GetOutlookApp = Nothing
    Resume ProcExit
    
End Function
Private Sub SendEmail(ByVal EmailTo As String, _
                      ByVal EmailCC As String, _
                      ByVal EmailBody As String, _
                      ByRef EmailSubject As String, _
                      ByVal EmailSignature As String, _
                      ByRef OutlookApp As Object)
'EmailSubject is ByRef so it can be permanently modified.
'Dim EmailItem As Outlook.MailItem
Dim EmailItem As Object

Const EMAIL_ITEM = 0
    Set EmailItem = OutlookApp.CreateItem(EMAIL_ITEM)
    If EmailSignature = "" Then EmailSignature = EmailItem.Body
    
    With EmailItem
        .To = EmailTo
        .CC = EmailCC
        .Subject = EmailSubject
        .Body = EmailBody & vbCrLf & EmailSignature
        .Send
       
    End With
    End Sub

I thought .SentOnBehalfOfName = "email@.co.uk" might be an option or outlook 2016 using Set.SentOnBehalfOfName = "email@.co.uk" but this does not send the emails.
Any thoughts would be appreciated.

Frothingslosh · Mar 8, 2018

You need to either log in AS that account or have been granted Send on Behalf rights. That's hard-coded into Outlook itself.

janeyg · Mar 9, 2018

Many thanks for this - I am investigating permissions as logging in as that account is requesting access before each email which is not feasible, our IT department have this locked down so I think permissions may be the way forward.

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

janeyg

Registered User.

Frothingslosh

Premier Pale Stale Ale

janeyg

Registered User.

janeyg

Registered User.

janeyg

Registered User.

Frothingslosh

Premier Pale Stale Ale

janeyg

Registered User.

janeyg

Registered User.

Frothingslosh

Premier Pale Stale Ale

Frothingslosh

Premier Pale Stale Ale

Attachments

janeyg

Registered User.

Frothingslosh

Premier Pale Stale Ale

janeyg

Registered User.

janeyg

Registered User.

Frothingslosh

Premier Pale Stale Ale

janeyg

Registered User.

Similar threads

Users who are viewing this thread