Email to particular recipients (1 Viewer)

lookforsmt

Registered User.
Local time
Today, 14:55
Joined
Dec 26, 2011
Messages
672
Dear pbaldy, Thank you for looking into this. Would you mind to put the code in the post, as i am not able to figure it out. I have tired changing the lines but with no luck.
I appreciate your time
 

pbaldy

Wino Moderator
Staff member
Local time
Today, 03:55
Joined
Aug 30, 2003
Messages
36,118
I'm away from my PC for a couple of days. I think all I did was comment out those 2 lines plus move the line that closed out the html table.
 

lookforsmt

Registered User.
Local time
Today, 14:55
Joined
Dec 26, 2011
Messages
672
Appreciate your time to respond to this post.

i am trying to figure out at which 2 lines i need to get rid of and change the order. For your ease i am putting the entire code from the db (SendEmail_2c) attached in post #13

Let me know which line i need to delete please in order to get the result you have posted in post #20

Option Compare Database
Option Explicit

Private Sub send_mail_Click()
'modified by thedbguy@gmail.com
'8/22/2015

'Create application and mail objects
Dim olApp As Object
Dim objMail As Object
Dim db As DAO.Database
Dim rs1 As DAO.Recordset
Dim rs2 As DAO.Recordset
Dim strID As String
Dim strTable As String
Dim strName As String
Dim strEmailTo As String
Dim strEmailcc As String
Dim rowColor As String
Dim i As Integer

Set db = CurrentDb()

'loop through query records
Set rs1 = CurrentDb.OpenRecordset("SELECT DISTINCT DispatchLocation FROM qryDataToSend", dbOpenSnapshot)

Do While Not rs1.EOF
Set rs2 = CurrentDb.OpenRecordset("SELECT * FROM qryDataToSend WHERE DispatchLocation='" & rs1!DispatchLocation & "'", dbOpenSnapshot)
Do While Not rs2.EOF
'Email header
' strName = rs2!DispatchLocation
strName = "<b><i>Dear All,</i></b><br>" & vbNewLine & vbCrLf & "<br><i>Below is the summary of returns and dispatch status</i><br>" _
& "<b><i></i></b><br>" _

strEmailTo = rs2!email_Id_To
strEmailcc = rs2!email_Id_cc
'list of courses
strTable = strTable & "<tr><td>" & rs2!CustomerAC & "</td>"
strTable = strTable & "<td align='center'>" & rs2!RejectReason & "</td>"
strTable = strTable & "<td align='center'>" & rs2!DispatchLocation & "</td>"
strTable = strTable & "<td align='center'>" & rs2!RejectDate & "</td>"
rs2.MoveNext
Loop

On Error Resume Next 'Keep going if there is an error
Set olApp = GetObject(, "Outlook.Application") 'See if Outlook is open

If Err Then 'Outlook is not open
Set olApp = CreateObject("Outlook.Application") 'Create a new instance
End If

'Create e-mail item
Set objMail = olApp.CreateItem(olMailItem)
'-------------------------------------------------------------
i = 0
Do While Not rs1.EOF
If (i Mod 2 = 0) Then
rowColor = "<td align=center bgcolor='#FFFFFF'> "
Else
rowColor = "<td align=center bgcolor='#E1DFDF'> "
End If
'---------------------------------------------------------------
With objMail
.BodyFormat = olFormatHTML
.To = strEmailTo
.CC = strEmailcc
.Subject = "NPDD Deadline Reminder"
.HTMLBody = "<!DOCTYPE html>"
.HTMLBody = .HTMLBody & "<html><head><style>table, th, td {border: 1px solid black;}</style></head><body>"
' .HTMLBody = .HTMLBody & "Dear " & strName & "," & "<p>"
.HTMLBody = .HTMLBody & strName & "<p>"
' .HTMLBody = .HTMLBody & "Below are your courses that the NPDD deadline is near blah blah ..."
.HTMLBody = .HTMLBody & "<table style='width:40%'>" 'Change table width here
.HTMLBody = .HTMLBody & "<tr bgcolor='#7EA7CC'><td>CustomerAC</td>" 'Change head row back color here
.HTMLBody = .HTMLBody & "<td align='center'>RejectReason</td>"
.HTMLBody = .HTMLBody & "<td align='center'>DispatchLocation</td>"
.HTMLBody = .HTMLBody & "<td align='center'>RejectDate</td></tr>"
.HTMLBody = .HTMLBody & strTable

'Add signatue line end of the body and send
' .HTMLBody = .HTMLBody & "</table><p>" & "Signature" & "<br>" & "Company" & "</body></html>"
.HTMLBody = .HTMLBody & "</table><p>" & "Thanks and Regards" & "</body></html>"

'.send
.Display
End With
strTable = ""
rs1.MoveNext
'-------------------------------------------------------------------
' rs.MoveNext
i = i + 1
Loop
strTable = strTable & "</table>"
'-------------------------------------------------------------------
Loop
If strTable = "" Then
MsgBox "NO Data Found!!!"
Exit Sub 'Exit the sub routine.
End If
'----------------------------------------------------------
MsgBox "Reports have been sent", vbOKOnly

Set rs2 = Nothing
Set rs1 = Nothing
Set db = Nothing
Set olApp = Nothing
Set objMail = Nothing

End Sub

Thank you
 

pbaldy

Wino Moderator
Staff member
Local time
Today, 03:55
Joined
Aug 30, 2003
Messages
36,118
Try

Code:
Private Sub send_mail_Click()
'modified by thedbguy@gmail.com
'8/22/2015

'Create application and mail objects
Dim olApp As Object
Dim objMail As Object
Dim db As DAO.Database
Dim rs1 As DAO.Recordset
Dim rs2 As DAO.Recordset
Dim strID As String
Dim strTable As String
Dim strName As String
Dim strEmailTo As String
Dim strEmailcc As String
Dim rowColor As String
Dim i As Integer

Set db = CurrentDb()

'loop through query records
Set rs1 = CurrentDb.OpenRecordset("SELECT DISTINCT DispatchLocation FROM qryDataToSend", dbOpenSnapshot)

Do While Not rs1.EOF
Set rs2 = CurrentDb.OpenRecordset("SELECT * FROM qryDataToSend WHERE DispatchLocation='" & rs1!DispatchLocation & "'", dbOpenSnapshot)
Do While Not rs2.EOF
'Email header
' strName = rs2!DispatchLocation
strName = "<b><i>Dear All,</i></b><br>" & vbNewLine & vbCrLf & "<br><i>Below is the summary of returns and dispatch status</i><br>" _
& "<b><i></i></b><br>" _

strEmailTo = rs2!email_Id_To
strEmailcc = rs2!email_Id_cc
'list of courses
strTable = strTable & "<tr><td>" & rs2!CustomerAC & "</td>"
strTable = strTable & "<td align='center'>" & rs2!RejectReason & "</td>"
strTable = strTable & "<td align='center'>" & rs2!DispatchLocation & "</td>"
strTable = strTable & "<td align='center'>" & rs2!RejectDate & "</td>"
rs2.MoveNext
Loop
strTable = strTable & "</table>"

On Error Resume Next 'Keep going if there is an error
Set olApp = GetObject(, "Outlook.Application") 'See if Outlook is open

If Err Then 'Outlook is not open
Set olApp = CreateObject("Outlook.Application") 'Create a new instance
End If

'Create e-mail item
Set objMail = olApp.CreateItem(olMailItem)
'-------------------------------------------------------------
i = 0
'Do While Not rs1.EOF
If (i Mod 2 = 0) Then
rowColor = "<td align=center bgcolor='#FFFFFF'> "
Else
rowColor = "<td align=center bgcolor='#E1DFDF'> "
End If
'---------------------------------------------------------------
With objMail
.BodyFormat = olFormatHTML
.To = strEmailTo
.CC = strEmailcc
.Subject = "NPDD Deadline Reminder"
.HTMLBody = "<!DOCTYPE html>"
.HTMLBody = .HTMLBody & "<html><head><style>table, th, td {border: 1px solid black;}</style></head><body>"
' .HTMLBody = .HTMLBody & "Dear " & strName & "," & "<p>"
.HTMLBody = .HTMLBody & strName & "<p>"
' .HTMLBody = .HTMLBody & "Below are your courses that the NPDD deadline is near blah blah ..."
.HTMLBody = .HTMLBody & "<table style='width:40%'>" 'Change table width here
.HTMLBody = .HTMLBody & "<tr bgcolor='#7EA7CC'><td>CustomerAC</td>" 'Change head row back color here
.HTMLBody = .HTMLBody & "<td align='center'>RejectReason</td>"
.HTMLBody = .HTMLBody & "<td align='center'>DispatchLocation</td>"
.HTMLBody = .HTMLBody & "<td align='center'>RejectDate</td></tr>"
.HTMLBody = .HTMLBody & strTable

'Add signatue line end of the body and send
' .HTMLBody = .HTMLBody & "</table><p>" & "Signature" & "<br>" & "Company" & "</body></html>"
.HTMLBody = .HTMLBody & "</table><p>" & "Thanks and Regards" & "</body></html>"

'.send
.Display
End With
strTable = ""
rs1.MoveNext
'-------------------------------------------------------------------
' rs.MoveNext
i = i + 1
'Loop

'-------------------------------------------------------------------
Loop
If strTable = "" Then
MsgBox "NO Data Found!!!"
Exit Sub 'Exit the sub routine.
End If
'----------------------------------------------------------
MsgBox "Reports have been sent", vbOKOnly

Set rs2 = Nothing
Set rs1 = Nothing
Set db = Nothing
Set olApp = Nothing
Set objMail = Nothing

End Sub
 

lookforsmt

Registered User.
Local time
Today, 14:55
Joined
Dec 26, 2011
Messages
672
Thanks pbaldy, much appreciated. marking this thread as solved
 

Users who are viewing this thread

Top Bottom