Option Explicit
Sub IWantMySixPackOfCarlsbergIWantItAllAndIWantItNow()
'
' constants
Const ksWS = "Customer Renewal"
Const ksMailLastDate = "MailLastDateCell"
Const kiMailStatus = 3
Const ksMailAddress = 4
Const kiMailDate = 17
Const ksMailStatusChanged = "Not Sent"
Const ksMailStatusUpdated = "Sent"
Const ksMailBCC = "purchasing@.co.uk"
Const ksMailAttachment = "C:\Renewal\CustRenewal.docx"
Const ksMailMe = "pirulito@.co.uk"
'
' declarations
' general
Dim dMailLastDate As Date, iMailSent As Integer
Dim I As Long, J As Integer
' outlook
Dim OutApp As Object, OutMail As Object
Dim strTo As String, strCC As String, strBCC As String
Dim strSub As String, strBody As String, strAttachment As String
'
' start
' general
dMailLastDate = Worksheets(ksWS).Range(ksMailLastDate).Cells(1, 1).Value
iMailSent = 0
' outlook
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
'
' process
With Worksheets(ksWS)
' check changes
I = 3
Do Until .Cells(I, 1).Value = ""
' send mail
If .Cells(I, kiMailStatus).Value = ksMailStatusChanged Then
strTo = .Cells(I, 4).Value
strCC = ""
strBCC = ksMailBCC
strSub = "Contract Renewal Number : " & _
.Cells(I, 1).Value & " - " & .Cells(I, 9).Value
strBody = "Dear " & .Cells(I, 8).Value & vbNewLine & vbNewLine & _
"The renewal/notice for termination date for the above contract was reached on " & _
Format(.Cells(I, 6).Value, "dd/mm/yyyy") & vbNewLine & vbNewLine & _
"Please take the necessary action within 30 calendar days to either renew or terminate this contract." & _
vbNewLine & vbNewLine & _
"Kind Regards," & vbNewLine & vbNewLine & _
"Mangala Wickramasinghe." & vbNewLine & _
"Finance Department"
strAttachment = ksMailAttachment
With OutMail
.To = strTo
.CC = strCC
.BCC = strBCC
.Subject = strSub
.Body = strBody
'You can add a file to the mail
If strAttachment <> "" Then .Attachments.Add (strAttachment)
'Change This from Display to Send to Automatically Send
.Display
'.Send
End With
.Cells(I, kiMailDate).Value = Now() 'Int(Now()) if don't want h:m:s
End If
' count changes
If .Cells(I, kiMailDate).Value > dMailLastDate Then iMailSent = iMailSent + 1
' cycle
I = I + 1
Loop
' send summary mail
strTo = ksMailMe
strCC = ""
strBCC = ksMailBCC
strSub = "Contract Renewal - Daily sent mails summary: " & Now() & " : " & iMailSent & " mails"
strBody = strSub
strAttachment = ""
With OutMail
.To = strTo
.CC = strCC
.BCC = strBCC
.Subject = strSub
.Body = strBody
'You can add a file to the mail
If strAttachment <> "" Then .Attachments.Add (strAttachment)
'Change This from Display to Send to Automatically Send
.Display
'.Send
End With
End With
'
' end
' outlook
Set OutMail = Nothing
Set OutApp = Nothing
' general
Worksheets(ksWS).Range(ksMailLastDate).Cells(1, 1).Value = Now()
Beep
'
End Sub
