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
