Dim rs As Recordset
Dim strSQL As String
Dim strWhere As String
Dim strFileName As String
Dim OutApp As Object
Dim OutMail As Object
Dim strEmailAdd As String
Dim strMsg As String
Dim strSubject As String
Dim Current_Time As Integer
Dim Greeting As String
Dim strSignature As String
strSQL = "SELECT Email FROM qryStatementTotalnvoice"
'Open a recordset of your email addresses from your reports underlying query
Set rs = CurrentDb.OpenRecordset(strSQL, dbOpenSnapshot)
If rs.EOF Or rs.BOF Then
MsgBox "No records for report!"
Exit Sub
End If
rs.MoveFirst
Current_Time = Hour(Now())
If Current_Time < 12 Then
Greeting = "Morning "
ElseIf Current_Time >= 18 Then
Greeting = "Evening "
Else
Greeting = "Afternoon "
End If
strSubject = "Your latest Invoice Statement"
strMsg = "<style> " & _
"p {font-size:11pt; font-family:Calibri}" & _
"</style>" & _
"<p>" & "Good " & Greeting & "," & "</p>" & _
"<p>" & "" & "</p>" & _
"<p>" & "Attached is the your latest staetment. " & _
"<p>" & "Any queries please let me know. " & _
"<p>" & "Thank You"
While Not rs.EOF
' Set up the filter
strEmailAdd = rs.Fields("Email")
strWhere = "Email = '" & strEmailAdd & "'"
' We need to save the files with a unique name
strFileName = Application.CurrentProject.Path & "\InvReport_" & strEmailAdd & ".PDF"
' Now open the filtered report and save it
DoCmd.OpenReport "rptStatementTotalnvoice", acViewPreview, , strWhere, acWindowNormal
DoCmd.OutputTo acOutputReport, , acFormatPDF, strFileName, , , , acExportQualityPrint
DoCmd.Close acReport, "rptStatementTotalnvoice"
' OUTLOOK Sending Bits
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.BodyFormat = 2 'olFormatHTML
.Display
End With
' This grabs your default signature saves it ready to add to the email with the attachment.
strSignature = OutMail.HTMLBody
With OutMail
.To = strEmailAdd
.CC = ""
.BCC = ""
.Subject = strSubject
'.MailItem.ReplyRecipients.Add = "flibble@somewhere.com"
'.SentOnBehalfOfName = "flibble@somewhere.com"
.Attachments.Add strFileName
.HTMLBody = strMsg & strSignature
.Display 'or use .Send to immediately send. As this runs with .Display it will save the emails in your drafts.
.ReadReceiptRequested = False
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
rs.MoveNext
Wend
rs.Close
Set rs = Nothing
End Sub