Multiple EMails (1 Viewer)

[mike60smart]

Hi Everyone
I currently have a process that links to an Outlook Folder.

These emails are then parsed into a table and displayed on a Form.

I then have a Command Button that splits the email data into fields in a table and displayed on a Form named "frmTwo"

I then have a Command Button that inserts this data into 2 tables and this works just fine.

Each record on the Continuous Form has a Control named "ContactEmail"

How would I be able to send an email to each of the individual email address's??

Any help appreciated.

The code on the Command Button at the moment is as follows:-

Private Sub cmdIn_Click()

On Error GoTo cmdIn_Click_Error
    Me.RecordsetClone.Filter = "[Updated] = -1"
    Test Me.RecordsetClone.OpenRecordset
Exit Sub
cmdIn_Click_Error:
    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure cmdIn_Click of Sub Form_frmTwo"

End Sub

Sub Test(rs As DAO.Recordset)

    On Error GoTo Test_Error
    
If Me.Dirty Then Me.Dirty = False
Dim dbsMydbs As DAO.Database
Dim rstMyTable As DAO.Recordset
Dim rstOtherTable As DAO.Recordset
Dim strSQL As String
Dim lngOrgOpenCourseBookingID As Long
Dim VariableName As Long

lngOrgOpenCourseBookingID = VariableName

Set dbsMydbs = CurrentDb
Set rstMyTable = dbsMydbs.OpenRecordset("tblOrganisationOpenCourseBooking")
Set rstOtherTable = dbsMydbs.OpenRecordset("tblGroupCourseParticipants")
If rs.EOF Then
    MsgBox "No recs"
Else
With rs
    .MoveLast
   .MoveFirst
    MsgBox .RecordCount
Do Until .EOF
rstMyTable.AddNew
rstMyTable!ShortCourseBookingID = Me.txtShortCourseBookingID
rstMyTable!ContactFirstName = Me.ContactFirstName
rstMyTable!ContactSurname = Me.ContactSurname
rstMyTable!ContactEMail = Me.ContactEMail
rstMyTable!ContactPhoneNumber = Me.ContactPhone
rstMyTable!OrganisationNameID = Me.txtOrg
rstMyTable!Address = Me.txtOrgAddress
rstMyTable!BillingAddress = Me.txtBillingAddress
rstMyTable!NrPlacesBooked = Me.NrofParticipants
rstMyTable!PONumber = Me.PONumber
rstMyTable!Comments = Me.AdditionalComments
rstMyTable!RecordID = Me.id

rstMyTable.Update
rstMyTable.Bookmark = rstMyTable.LastModified
VariableName = rstMyTable!OrgOpenCourseBookingID

If Len(ParticipantName1 & vbNullString) > 0 Then
  rstOtherTable.AddNew
  rstOtherTable!OrgOpenCourseBookingID = VariableName
  rstOtherTable!ParticipantName = ParticipantName1
  rstOtherTable.Update
End If
If Len(ParticipantName2 & vbNullString) > 0 Then
  rstOtherTable.AddNew
  rstOtherTable!OrgOpenCourseBookingID = VariableName
  rstOtherTable!ParticipantName = ParticipantName2
  rstOtherTable.Update
End If
If Len(ParticipantName3 & vbNullString) > 0 Then
  rstOtherTable.AddNew
  rstOtherTable!OrgOpenCourseBookingID = VariableName
  rstOtherTable!ParticipantName = ParticipantName3
  rstOtherTable.Update
End If
If Len(ParticipantName4 & vbNullString) > 0 Then
  rstOtherTable.AddNew
  rstOtherTable!OrgOpenCourseBookingID = VariableName
  rstOtherTable!ParticipantName = ParticipantName4
  rstOtherTable.Update
End If
If Len(ParticipantName5 & vbNullString) > 0 Then
  rstOtherTable.AddNew
  rstOtherTable!OrgOpenCourseBookingID = VariableName
  rstOtherTable!ParticipantName = ParticipantName5
  rstOtherTable.Update
End If

   .MoveNext
Loop

End With
End If

MsgBox "Participants have been added.", vbInformation, "Complete"

DoCmd.RunMacro "mcrDeleteTable2True"


    On Error GoTo 0
    Exit Sub

Test_Error:

    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Test of Sub Form_frmTwo"

End Sub

 

[pbaldy]

Open a recordset on the table or a query. Within a loop of that recordset, send an email. You can also build a string of the addresses and just send one email after the loop if you want.

 

[mike60smart]

Hi Paul

Can you give me an example of how I can do this? My VBA skills are very limited.

 

[pbaldy]

An example of what exactly? You're already using a loop. Does this help?

http://www.granite.ab.ca/access/email/recordsetloop.htm

Click on the "Email" link to get info about different email methods.

 

[mike60smart]

Hi Paul

I am trying to use the following Code from the link you supplied.

When I try to run it I get the following error:-



The Code is:-

Private Sub cmdSendEmail_Click()

On Error GoTo cmdSendEMail_Click_Error
    Me.RecordsetClone.Filter = "[Updated] = -1"
    Test Me.RecordsetClone.OpenRecordset
Exit Sub
cmdSendEMail_Click_Error:
    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure cmdSendEMail_Click of Sub Form_frmTwo"
End Sub

  
Private Sub cmdEMail_Click()
On Local Error GoTo Some_Err
    
    Dim MyDB As Database, RS As Recordset
    Dim strbody As String, lngCount As Long, lngRSCount As Long
    
    DoCmd.RunCommand acCmdSaveRecord
    Set MyDB = DBEngine.Workspaces(0).Databases(0)
    
 
   Set RS = MyDB.OpenRecordset("Email Confirmations")
    lngRSCount = RS.RecordCount
    
    If lngRSCount = 0 Then
      MsgBox "No confirmation email messages to send.", vbInformation
    Else
      RS.MoveLast
      RS.MoveFirst
      Do Until RS.EOF
        lngCount = lngCount + 1
        
   
   On Error Resume Next
    Dim OutApp As Object
    Dim OutMail As Object
   
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    strbody = "Hi," & vbNewLine & vbNewLine & _
    "This is confirmation of your Group Open Course for " & Me.CourseTitle & " " & Me.CourseDate & " ." & vbNewLine & _
    "" & vbNewLine & vbNewLine & _
    "Thank you."
    On Error Resume Next

    With OutMail
        .Display
        .To = Me.ContactEMail
        .CC = ""
        .BCC = ""
        .Subject = "Group Open Course - " & Me.CourseTitle & " " & Me.CourseDate
        .Body = strbody & vbNewLine & .Body
    End With

    On Error GoTo 0
    Set OutMail = Nothing
    Set OutApp = Nothing

      Loop
    
    End If
    RS.Close
    MyDB.Close
    Set RS = Nothing
    Set MyDB = Nothing
    Close
    
    Exit Sub
    
Some_Err:
    
    MsgBox "Error (" & CStr(Err.Number) & ") " & Err.Description, _
        vbExclamation, "Error!"
    
End Sub

 

[pbaldy]

The error refers to a sub called Test, which I don't see. Can you attach the db here?

 

[Cronk]

Paul, Test code was in #1

I'd guess the error is from not creating a recordset object from the filtered source

eg
dim rst as recordset
set rst = Me.RecordsetClone.OpenRecordset
Test rst
set rst = nothing

 

[pbaldy]

The test sub in post 1 didn't do what was requested, it came from another thread. I think...

 

[mike60smart]

Hi Paul & Cronk

Many thanks for taking a look at this for me.

I have managed to get a different piece of code but when I run the code it places all of the recipients into the One Email.

How could I modify the following code so that it creates individual emails for each recipient??

Any help appreciated.

Code is :-

Private Sub cmdEmailRecips_Click()
    
On Error GoTo Some_Err
 
Dim rst As DAO.Recordset
Dim strEmailAddress As String
Dim strSubject As String
Dim strEMailMsg As String

Set rst = CurrentDb.OpenRecordset("Table2")
strSubject = Me.CourseTitle
Do Until rst.EOF
strEmailAddress = strEmailAddress & rst("ContactEmail") & ","
rst.MoveNext
Loop

strEmailAddress = Left(strEmailAddress, Len(strEmailAddress) - 1)

DoCmd.SendObject , , , strEmailAddress, , , "Group Open Course Confirmation", "This is confirmation of your Group Open Course Booking", True

rst.Close
Set rst = Nothing

Some_Err:
    
    MsgBox "Error (" & CStr(Err.Number) & ") " & Err.Description, _
        vbExclamation, "Error!"
End Sub

 

[pbaldy]

As I mentioned in post2, you can send the email within the loop instead of building the string.

 

[mike60smart]

Hi Paul

Are you saying that i should send the email within the loop of the code that I am currently using to carry out the Insert of Records??

 

[pbaldy]

No, in this one:

Do Until rst.EOF
strEmailAddress = strEmailAddress & rst("ContactEmail") & ","
rst.MoveNext
Loop

Instead of building the string, send the email.

 

[mike60smart]

Hi Paul

I changed the code as shown below but now when I run the code it opens an EMail for the First Recipient as expected but when I send the email it then opens the same email address again??

Code now is:-

Private Sub cmdEmailRecips_Click()
    
On Error GoTo Some_Err
 
Dim rst As DAO.Recordset
Dim strEMailAddress As String
Dim strSubject As String
Dim strEMailMsg As String

Set rst = CurrentDb.OpenRecordset("Table2")
strEMailAddress = Me.ContactEMail
strSubject = Me.CourseTitle

Do Until rst.EOF
DoCmd.SendObject , , , strEMailAddress, , , "Group Open Course Confirmation", "This is confirmation of your Group Open Course Booking", True
rst.MoveNext
Loop

rst.Close
Set rst = Nothing

Some_Err:
    
    MsgBox "Error (" & CStr(Err.Number) & ") " & Err.Description, _
        vbExclamation, "Error!"
End Sub

 

[pbaldy]

You get the address from the form, before the loop. You need to use rst("ContactEmail").

 

[mike60smart]

Hi Paul

Now when I run the code I get the following error:-



Code is now:-

Private Sub cmdEmailRecips_Click()
    
On Error GoTo Some_Err
 
Dim rst As DAO.Recordset
Dim strEMailAddress As String
Dim strSubject As String
Dim strEMailMsg As String

Set rst = CurrentDb.OpenRecordset("Table2")
strEMailAddress = Me.ContactEMail
strSubject = Me.CourseTitle

Do Until rst.EOF
DoCmd.SendObject , , , strEMailAddress, , , "Group Open Course Confirmation", "This is confirmation of your Group Open Course Booking", True
rst ("ContactEmail")
rst.MoveNext
Loop

rst.Close
Set rst = Nothing

Some_Err:
    
    MsgBox "Error (" & CStr(Err.Number) & ") " & Err.Description, _
        vbExclamation, "Error!"
End Sub

 

[pbaldy]

Use the recordset instead of the string you set before the loop:

DoCmd.SendObject , , , rst("ContactEmail"), , , "Group Open Course Confirmation", "This is confirmation of your Group Open Course Booking", True

 

[mike60smart]

Hi Paul

Many thanks yet again

Works a treat now.

 

[pbaldy]

No problem.