Sending Automated Email (1 Viewer)

[sarguzm]

Since it has been quite a few years, I am a bit rusty... I am trying to get Access to send automated emails based on certain criteria. I accomplished the sending automated emails part, but not the based on certain criteria part & I have been working on this far too long and just can't figure out what I am doing wrong!

Option Compare Database
Option Explicit
Private Sub Send_E_Click()
Sub SendMessages(Optional AttachmentPath)
Dim MyDB As Database
Dim MyRS As Recordset
Dim objOutlook As Outlook.Application
Dim objOutlookMsg As Outlook.mailItem
Dim objOutlookRecip As Outlook.Recipient
Dim objOutlookAttach As Outlook.Attachment
Dim TheAddress As String
Set MyDB = CurrentDb
Set MyRS = MyDB.OpenRecordset("MailingList")
MyRS.MoveFirst

If MyRS![Category] = "X" Then

' Create the Outlook session.
Set objOutlook = CreateObject("Outlook.Application")

Do Until MyRS.EOF
' Create the e-mail message.
Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
TheAddress = MyRS![EAddress]
With objOutlookMsg
' Add the To recipients to the e-mail message.
Set objOutlookRecip = .Recipients.Add(TheAddress)
objOutlookRecip.Type = olTo

' Set the Subject, Body, and Importance of the message.
.Subject = "This is an Automation test with Microsoft Outlook"
.Body = "This is the body of the message." & vbCrLf & vbCrLf

' Resolve the name of each Recipient.
For Each objOutlookRecip In .Recipients
objOutlookRecip.Resolve
If Not objOutlookRecip.Resolve Then
objOutlookMsg.Display
Else
End If
Next
.Send
End With
MyRS.MoveNext
Loop
Set objOutlookMsg = Nothing
Set objOutlook = Nothing
End If
End Sub

Any help would be greatly appreciated!

sarguzm

 

[pbaldy]

The bold line is before the loop, so it will act on the first record in the recordset, not each record.

 

[sarguzm]

Thank you Paul, I will try putting it after the loop.

sarguzm

 

[pbaldy]

Well, you probably want it in the loop, but what I would do:

Set MyRS = MyDB.OpenRecordset("SELECT * FROM MailingList WHERE [Category] = 'X'")

Which would give you a recordset with only the relevant records in it. Also a warning, the MoveFirst line will error if the recordset is empty. You don't need that line anyway.

 

[sarguzm]

Hi Paul,

I took your advice and took out the MoveFirst line and changed Set MyRS = MyDB.OpenRecordset("SELECT * FROM MailingList WHERE [Category] = 'X'")... It worked like a charm! I cannot thank you enough! Have a great day!

sarguzm

 

[pbaldy]

Happy to help!

 

[Steve400]

Looks like I'm trying to do the same thing.
Currently the code can populate the email with everything I want and works for 1 record.
But instead of looping to another email address in the recordset it just adds the same attachment to the first email.
Does someone know what I have done wrong in my loop?

Private Sub SendEmail_Click()

Dim DB As Database
Dim rsEmailList As DAO.Recordset

Set DB = CurrentDb
Set rsEmailList = DB.OpenRecordset("EmailList", dbOpenSnapshot)
Set EmailApp = CreateObject("Outlook.Application")
Set NameSpace = EmailApp.GetNamespace("MAPI")
Set EmailSend = EmailApp.CreateItem(0)

With rsEmailList
.MoveFirst
Do Until rsEmailList.EOF
If IsNull(.Fields(1)) = False Then
EmailSend.To = .Fields(1)
EmailSend.Subject = Me.Subject
EmailSend.Body = Me.Body1 & vbCrLf & Me.Body2 & vbCrLf & Me.Body3 & vbCrLf & Me.Body4
EmailSend.Attachments.Add "E:\" & Me.Attachment & ".doc"
EmailSend.Display


.MoveNext
Loop
End With
Set DB = Nothing
Set rsEmailList = Nothing
Set EmailApp = Nothing
Set NameSpace = Nothing
Set EmailSend = Nothing


End Sub

 

[pr2-eugin]

Steve400, I think you are using a Form to get a common message and subject.. I take this from the code you use Me. If the attachment for every person is different then should it not be obtained from the recordset? Also your code is missing a End If line..

Private Sub SendEmail_Click()
    Dim DB As Database
    Dim rsEmailList As DAO.Recordset

    Set DB = CurrentDb
    Set rsEmailList = DB.OpenRecordset("EmailList", dbOpenSnapshot)
    Set EmailApp = CreateObject("Outlook.Application")
    Set NameSpace = EmailApp.GetNamespace("MAPI")
    Set EmailSend = EmailApp.CreateItem(0)

    With rsEmailList
       [B][COLOR=Blue] .MoveFirst[/COLOR][/B]
        Do Until rsEmailList.EOF
            If IsNull(.Fields(1)) = False Then
                EmailSend.To = .Fields(1)
                EmailSend.Subject = Me.Subject
                EmailSend.Body = Me.Body1 & vbCrLf & Me.Body2 & vbCrLf & Me.Body3 & vbCrLf & Me.Body4
                EmailSend.Attachments.Add "E:\" & [COLOR=Red][B].Fields(2)[/B][/COLOR] & ".doc"
                EmailSend.Display
            [COLOR=Red][B]End If[/B][/COLOR]
            .MoveNext
        Loop
    End With
    Set DB = Nothing
    Set rsEmailList = Nothing
    Set EmailApp = Nothing
    Set NameSpace = Nothing
    Set EmailSend = Nothing
End Sub

The highlighted line would cause an Error if there are no records in the Recordset.. As Allen Browne describes..

Using any of the Move methods (MoveFirst, MoveLast, MoveNext, or MovePrevious) causes an error if the recordset has no records.

Solution:
Test before using any of the Move methods. Either of these approaches works:

If Not (rs.BOF And rs.EOF) Then 'There are no records if Beginning-Of-File and End-Of-File are both true.
If rs.RecordCount <> 0 Then '100% reliable in DAO, but some ADO recordsets return -1 as the count.

PS: Please use Code Tags when posting VBA Code

 

[Steve400]

Thanks pr2-eugin,

Correct - I am using a form with default text but the attachment, at this stage is the same for everyone.

I've removed the .MoveFirst and added the End If but am still getting the same issue. When multiple recipients are selected it is still only producing 1 email with duplicate attachments.

Do you have any other ideas?

Thanks

 

[pbaldy]

In a similar situation, I set the Outlook and mail variables inside the loop. That should make it create multiple emails. As is, it keeps using the same one.

 

[Steve400]

I changed the .Display to .Send. The first email sent as expected but it got stuck on the 'To" line of the 2nd record with the error: "This item has been moved or deleted"

 

[pbaldy]

Sure, and the same answer. You've sent the email without creating a new one.

 

[Steve400]

Thanks pbaldy,
Sorry I didn't read your post properly the first time, my fault. Worked perfectly.

You suggested before to have the attachment in the recordset. This is a good idea to send customised attachments and will also be useful to me.

Say that I had an Access form that I wanted to populate with customers's records and then send that record to the customer.

How would I get the attachments into the recordset?

 

[pr2-eugin]

You suggested before to have the attachment in the recordset. This is a good idea to send customised attachments and will also be useful to me.

That was my idea.. Ha ha, just kidding..

Anyway, you can create a new field in the table which will have the Link to the customer's letter.. Then include that in your Email Query, you should be good to go with the Code in Post#8

 

[Steve400]

Since you guys have been so helpful, I'll exploit your brilliance a little more.

The code below is basically the same above but instead of sending out the same form to everyone I want to add their ID to the form before I send it out.
This will help getting the data back into the database when it is returned.

Currently it is opening the form and adding the Key but is getting stuck adding the attachment to the email.

The If Me.Attachment statement is wrong but I can get around this using a resume next error statement.

The main problem seems to be the attachment.

Would love some help. Thanks


Private Sub SendEmail_Click()
Dim appword As Word.Application
Dim doc As Word.Document
Dim DB As Database
Dim rsEmailList As DAO.Recordset


If Me.Attachment = "None" Then Template = ignore Else Template = "E:\" & Me.Attachment & ".doc"


Set DB = CurrentDb
Set rsEmailList = DB.OpenRecordset("EmailList", dbOpenSnapshot)
Set appword = GetObject(, "Word.Application")
If Err.Number <> 0 Then
Set appword = New Word.Application
End If

With rsEmailList
'.MoveFirst
Do Until rsEmailList.EOF
If IsNull(.Fields(1)) = False Then

Set doc = appword.Documents.Open(Template)
With doc
.FormFields("key").Result = rsEmailList!Key
.Activate
End With

Set EmailApp = CreateObject("Outlook.Application")
Set NameSpace = EmailApp.GetNamespace("MAPI")
Set EmailSend = EmailApp.CreateItem(0)


EmailSend.To = .Fields(1)
EmailSend.Subject = Me.Subject
EmailSend.Body = Me.Body1 & vbCrLf & Me.Body2 & vbCrLf & Me.Body3 & vbCrLf & Me.Body4
EmailSend.Attachments.Add doc
EmailSend.Display
End If

.MoveNext
Loop
End With
Set DB = Nothing
Set rsEmailList = Nothing
Set EmailApp = Nothing
Set NameSpace = Nothing
Set EmailSend = Nothing
Set doc = Nothing
Set appword = Nothing

End Sub

 

[pbaldy]

Not clear on what the problem is, but with this code:

EmailSend.Attachments.Add

I'd expect a path to a file, like the Template variable. Not saying what you have won't work, as I've never tried it.

 

[Steve400]

ok,
How would you structure code to open a word form, populate a form field, attach the form to an email and loop through a recordset?

 

[pbaldy]

I've never needed to automate Word. Offhand, I'd save the file after you've populated it and then attach it. I've done that with Excel files many times.

 

[Steve400]

You were right, that works.
Nearly there.
Only problem is that it's 'saving as' and attaching as an MS doc application.
It's weird. Can you see what I've done?

Private Sub SendEmail_Click()
Dim db As dao.Database
Dim rsEmailList As dao.Recordset
Dim Path As String
Dim objWord As Object
Dim FileN As String
Dim NewDoc As New Word.Document

'On Error Resume Next
'Err.Clear

If Me.Attachment = "None" Then Path = ignore Else Path = "E:\" & Me.Attachment & ".doc"

Set db = CurrentDb
Set rsEmailList = db.OpenRecordset("EmailList", dbOpenSnapshot)

With rsEmailList

Do Until rsEmailList.EOF
If IsNull(.Fields(1)) = False Then

Set objWord = CreateObject("word.application")
objWord.Visible = False
Set NewDoc = objWord.Documents.Add(Path)

With NewDoc
.FormFields("key").Result = rsEmailList!Key
.Activate
End With

FileN = "E:\" & (.Fields(4)) & Me.Attachment & ".com"
objWord.ActiveDocument.SaveAs FileName:=FileN, FileFormat:=wdFormatDocument


Set EmailApp = CreateObject("Outlook.Application")
Set NameSpace = EmailApp.GetNamespace("MAPI")
Set EmailSend = EmailApp.CreateItem(0)


EmailSend.To = .Fields(1)
EmailSend.Subject = Me.Subject
EmailSend.Body = Me.Body1 & vbCrLf & Me.Body2 & vbCrLf & Me.Body3 & vbCrLf & Me.Body4
EmailSend.Attachments.Add "E:\" & (.Fields(4)) & Me.Attachment & ".com"
EmailSend.Display
End If

.MoveNext
Loop
End With
Set db = Nothing
Set rsEmailList = Nothing
Set EmailApp = Nothing
Set NameSpace = Nothing
Set EmailSend = Nothing
Set NewDoc = Nothing
Set objWord = Nothing

End Sub

 

[pbaldy]

Do you really want it saved with a .com extension?