Send E-mail from Query Results (1 Viewer)

[jonedcc]

Hi everyone,

I found the base code very useful however the outlook error made the code unusable; here is a modified version which does not result in an error:



Public Function SendNewEMail()

'qryQueryName = the name of the query you want to send e-mails from
'x = the column # of the field with e-mail address
'y = the column # of field with invoice number
'a,b,c = the colum # of fields if you want the e-mail body to have more information from the query (if not/more, you can delete/add as appropriate)

Dim OutApp As Object
Dim OutMail As Object

Dim MyDb As DAO.Database
Dim rsEmail As DAO.Recordset

Set MyDb = CurrentDb()
Set rsEmail = MyDb.OpenRecordset("qryQueryName", dbOpenSnapshot)

With rsEmail
.MoveFirst
Do Until rsEmail.EOF

If IsNull(.Fields(x)) = False Then
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail

.To = rsEmail.Fields(x)
.Subject = "" & rsEmail.Fields
.HTMLBody = "Email Body Text " & vbCrLf & _
"Field A: " & .Fields(a) & vbCrLf & _
"Field B: " & .Fields(b) & vbCrLf & _
"Field C: " & .Fields(c)
'.display
.send

End With
End If
.MoveNext
Loop
End With

Set MyDb = Nothing
Set rsEmail = Nothing

End Function

 

[pbaldy]

Is the body properly formatted?

 

[emohammed]

This works fine --- how could I add formatting to this email (for example Bold and lines)...

Think something like this will work for you. You can set this up on a button or a timer, or what-have-you.

Dim MyDb As DAO.Database
Dim rsEmail As DAO.Recordset
Dim sToName As String
Dim sSubject As String
Dim sMessageBody As String
 
Set MyDb = CurrentDb()
Set rsEmail = MyDb.OpenRecordset("qryQueryName", dbOpenSnapshot)
 
With rsEmail
        .MoveFirst
        Do Until rsEmail.EOF
            If IsNull(.Fields(x)) = False Then
                sToName = .Fields(x) 
                sSubject = "Invoice #: " & .Fields(y) 
                sMessageBody = "Email Body Text " & vbCrLf & _
                    "Field A: " & .Fields(a) & vbCrLf & _
                    "Field B: " & .Fields(b) & vbCrLf & _
                    "Field C: " & .Fields(c)
 
                DoCmd.SendObject acSendNoObject, , , _
                    sToName, , , sSubject, sMessageBody, False, False
            End If
            .MoveNext
        Loop
End With
 
Set MyDb = Nothing
Set rsEmail = Nothing

You can test this on a button, but here is what goes down ...

First, look at your query and see how your columns are defined. Note, the order of your fields, for instance if the e-mail address is in the first column, that column index is 0 (the query columns go from 0 to n).

Note a recordset uses the term 'fields' for columns so assign the correct field/column numbers in the above code:


With , I put the invoice number in the subject line - you can move it whereever, just wanted to give you a good enough example to work off of.
Also, I had it check field(x) (the email field) to see if there was an e-mail there, if not, it ignores that record.

Hope that helps,
-dK

 

[vbaInet]

emohammed,

jonedcc's last post (#61) has code that allows you to send formatted text using the Outlook object. You will need to use HTML tags to format your text.
This cannot be achieved using Access' SendObject.

 

[pbaldy]

You have to use automation and HTMLBody.

 

[LisaLu]

Is it OK if I revive this old thread? I am having a similar situation however I am getting a run-time error stating that the item has been moved or deleted. I will paste my code below. The error is occurring on the .To = sToName line. I am not an advanced coder, I have combined some older code I used in another database with a loop to send the emails from the query result. The first email goes fine, then the error occurs on the second trip through the loop. I have been staring at this for a long time. Any input is appreciated.
Thanks!

Public Function EmailExpirationNotice()



Dim myDb As DAO.Database
Dim rsEmail As DAO.Recordset
Dim sToName As String
Dim sSubject As String
Dim sMessageBody As String

Dim OutApp As Outlook.Application
Dim myItem As Outlook.mailItem
Dim MyMail As Object



Set myDb = CurrentDb()
Set OutApp = CreateObject("Outlook.Application")
Set myItem = OutApp.CreateItem(olMailItem)
Set MyMail = CreateObject("Outlook.application").CreateItem(0)
Set rsEmail = myDb.OpenRecordset("qrySelectToSend", dbOpenSnapshot)



With rsEmail
.MoveFirst
Do Until rsEmail.EOF
If IsNull(.Fields(0)) = False Then
sToName = .Fields(0)
sSubject = "Subject " & .Fields(2)
sMessageBody = "Your Contract will expire Soon - Please Review"

End If
With MyMail
.To = sToName
.BCC = sToName
.Subject = sSubject
.Body = sMessageBody
.SendUsingAccount = OutApp.Session.Accounts.Item(1)
.Send
End With

.MoveNext




Loop
End With

 

[pbaldy]

You have some mixed methodology there, but you need to set the MyMail variable inside the loop.

 

[LisaLu]

Oh, wow. Thank you. That makes perfect sense and fixed my problem.

Yes, my methods are mixed due to the fact I have no formal training and learned everything on the job. I guess I'm a real programmers worst nightmare.

Thank you so much!

 

[pbaldy]

Happy to help! By the way, I also "have no formal training and learned everything on the job". Don't worry, it gets easier!

 

[Poco_90]

I know this is an old post, but I tried the code and was having some issues with it and Outlook 2016. The first error was stopping at

.To = rsEmail.Fields(7)

Thanks to Pauls post on
http://www.accessforums.net/showthread.php?t=57490

I got the code somewhat working. I then started to get errors with & vbCrLf & _ in the .body section. I wasn't sure how to overcome this so I used & "<br>" &

Just in case anyone is looking at this thread, this is what worked for me.

Public Function SendNewEMail()

'qryQueryName = the name of the query you want to send e-mails from
'x = the column # of the field with e-mail address
'y = the column # of field with invoice number
'a,b,c = the colum # of fields if you want the e-mail body to have more information from the query (if not/more, you can delete/add as appropriate)

Dim OutApp As Object
Dim OutMail As Object
Dim strEmail As String




Dim MyDb As DAO.Database
Dim rsEmail As DAO.Recordset

Set MyDb = CurrentDb()
Set rsEmail = MyDb.OpenRecordset("qryLateTest", dbOpenSnapshot)

With rsEmail
.MoveFirst
Do Until rsEmail.EOF

If IsNull(.Fields(7)) = False Then
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail

strEmail = rsEmail.Fields(7)
.To = strEmail
'.To = rsEmail.Fields(7)

.Subject = "" & "***OverDue Item: " & rsEmail.Fields(8) & " Days: " & rsEmail.Fields(1)
.Importance = 2
.HTMLBody = "***OVERDUE*** " & rsEmail.Fields(1) & "<br>" & " No of Days Overdue: " & rsEmail.Fields(8) & "<br>" & "Person Resonsible: " & rsEmail.Fields(6) & "<br>" & "Employee affected(if applicable): " & rsEmail.Fields(9)


'.display
.send

End With
End If
.MoveNext
Loop
End With

Set MyDb = Nothing
Set rsEmail = Nothing

End Function

Poco

 

[pbaldy]

Glad you got it working. vbCrLf would work with regular format, <br> is for html.

 

[Hayes8052]

Good day,
I am using Access 2010.
I am still a beginner in VB Access and self taught.
The below code works great. I have 2 problems and would like some assistance as to how to fix them.

1. When there is more than on contract for that region I would like to consolidate all the contracts into 1 Email and not multiple Emails
2. When there are no contracts expiring I get and error

'------------------------------------------------------------
' Send Email for contracts expiring in 30 days
'
'------------------------------------------------------------
Private Sub Email30_Click()
Dim MyDb As DAO.Database
Dim rsEmail As DAO.Recordset
Dim sToName As String
Dim sSubject As String
Dim sMessageBody As String
 
Set MyDb = CurrentDb()
Set rsEmail = MyDb.OpenRecordset("Expire_30_Email", dbOpenSnapshot)
 
With rsEmail
        .MoveFirst
        Do Until rsEmail.EOF
            If IsNull(.Fields(8)) = False Then
                sToName = .Fields(8)
                sSubject = "The Following Contracts are going to expire in the next 30 days: "
                sMessageBody = "The Following Contracts are going to expire in the next 30 days." & vbCrLf & "Please initiate the Addendum Process" & vbCrLf & _
                    "Contract No: " & .Fields(0) & vbCr & vbCrLf & _
                    "Project Name: " & .Fields(1) & vbCr & _
                    "Company: " & .Fields(2) & vbCr & vbCr & _
                    "Regards" & vbCrLf & "Contract Management Team"
 
                DoCmd.SendObject acSendNoObject, , , _
                    sToName, , , sSubject, sMessageBody, False, False
            End If
            .MoveNext
        Loop
End With
 
Set MyDb = Nothing
Set rsEmail = Nothing
End Sub

 

[pbaldy]

The .MoveFirst will throw an error if there are no records, and in my experience is not necessary. The recordset will start at the first record unless told otherwise.

Not sure of your specifics, but if you just want to send one email, you can build a string of contract numbers in the loop and then send the email after it.

 

[Hayes8052]

Good day pbaldy,
Thank you for your feedback it is appreciated.
I am new to VB and not sure how to go about building a string. I would need to build the string around the the Email address as that is linked to the region/Business unit responsible for the contract. any assistance would be appreciated.

 

[pbaldy]

Inside the loop you would build a string of addresses:

sToName = sToName & ";" & .Fields(8)

Then send the mail after the loop.

 

[Hayes8052]

Good day pbaldy,
Thank you. I will give it a shot. Appreciated.

 

[pbaldy]

No problem, post back if you get stuck.

 

[Hayes8052]

Hi pbaldy,
I am attempting the loop but now I get the following error and not sure how to fix it.
error 2295 Run time error. The comment is unknown message recipients.
Below is the code I am using.

Private Sub Email30_Click()
Dim MyDb As DAO.Database
Dim rsEmail As DAO.Recordset
Dim sToName As String
Dim sSubject As String
Dim sMessageBody As String
 
 
Set MyDb = CurrentDb()
Set rsEmail = MyDb.OpenRecordset("Expire_30_Email", dbOpenSnapshot)
 
With rsEmail
        '.MoveFirst
        Do While Not rsEmail.EOF
            If IsNull(.Fields(9)) = False Then
                'sToName = .Fields(9)
                sToName = sToName & ";" & .Fields(9)
                sSubject = "The Following Contracts are going to expire in the next 30 days: "
                sMessageBody = "The Following Contracts are going to expire in the next 30 days." & vbCrLf & "Please initiate the Addendum Process" & vbCrLf & _
                    "Contract No: " & .Fields(0) & vbCr & vbCrLf & _
                    "Project Name: " & .Fields(1) & vbCr & _
                    "Company: " & .Fields(2) & vbCr & vbCr & _
                    "Regards" & vbCrLf & "Contract Management Team"
 
                DoCmd.SendObject acSendNoObject, , , _
                    sToName, , , sSubject, sMessageBody, False, False
            End If
            rsEmail.MoveNext
        Loop
End With
 
Set MyDb = Nothing
Set rsEmail = Nothing
End Sub

 

[pbaldy]

That's sending the email within the loop, so you'd send it to an increasingly large group of people. What does the variable contain when you get the error? You can use this:

http://www.baldyweb.com/ImmediateWindow.htm

or while in debug mode type this in the Immediate window:

?sToName

and hit enter.

 

[Hayes8052]

Thank you Paul for your assistance. This became to complex and went for the option to design certain reports for the regions. Once again thanks for your efforts.