Send Outlook Mail based on value changes in cell

elsuji · Apr 19th 2020

Dear Team,

I am updating calibration data's on my excel. In that the last calibration date entered on column G and Next due date will update automatically on Column H which is 90 days time period. In column I update for remaining days. I want to send remainder mail to my customer before 10 days( between 1 to 10 days) of expire the next due date.

For that i had created code for send separate email for each customers. But the mail opening only for the row where i am selecting. First it should check the value on column I where the values between 1 to 10 days and send mail only to that customers.

Once the mail is sent to customer it should print on column J like Mail sent

I attached my file here for your reference.

Kindly do the need full for completing this work.

p45cal · Apr 20th 2020

Cross posted without links all over the place,

**royUK** · Apr 20th 2020

elsuji

Please add a list of all links. Read our Forum Rules to understand why

elsuji · Apr 20th 2020

Dear Roy,

The link is

http://www.vbaexpress.com/foru…-on-value-changes-in-cell

**royUK** · Apr 20th 2020

Is that the onlyone?

elsuji · Apr 20th 2020

There are two links

http://www.vbaexpress.com/forum/show...hanges-in-cell

and

https://www.excelforum.com/exc…alue-changes-in-cell.html

**royUK** · Apr 20th 2020

Thanks, I'll take a look later.

elsuji · Apr 20th 2020

Dear Roy,

Thanks for your reply.

The problem is solved and the code is

Code

Option Explicit
Sub Remindermail()
Dim lRow As Integer
Dim i As Integer
Dim toDate As Date
Dim toList, CCList As String
Dim eSubject As String
Dim eBody As String
Dim OutApp As Object, _
OutMail As Object
Dim Signature As String
Dim sPath As String
Dim S As String

With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .DisplayAlerts = False
End With

Sheets("Data").Select
lRow = Cells(Rows.Count, 4).End(xlUp).Row

Set OutApp = CreateObject("Outlook.Application")

S = Environ("appdata") & "\Microsoft\Signatures\"
If Dir(S, vbDirectory) <> vbNullString Then S = S & Dir$(S & "*.htm") Else S = ""
S = CreateObject("Scripting.FileSystemObject").GetFile(S).OpenAsTextStream(1, -2).ReadAll

For i = 4 To lRow
  If Cells(i, 9).Value >= 1 And Cells(i, 9).Value <= 10 And Cells(i, 10).Value = "" Then
     Set OutMail = OutApp.CreateItem(0)
        toList = Cells(i, 4)    'gets the recipient from col B
        'CCList = Cells(i, 8) & ", " & Cells(i, 9) & ", " & Cells(i, 10)
        eSubject = "Calibration remainder for your " & Cells(i, 5) & " Batching Plant "
        eBody = "<font style=""font-family:Cambria; font-size:12pt;""/font> Dear Sir, <br><br>" _
        & "Greetings from " & "<b> SCHWING STETTER! </b><br><br>" _
        & "Your " & "<b>" & Worksheets("Data").Cells(i, "E").Value & "</b>" _
        & " Batching Plant calibration certificate is going to expire soon ( within " _
        & "<b>" & Worksheets("Data").Cells(i, "I").Value & "</b>" & " days ).<br><br>" _
        & "Plant Last calibration done date is " & "<b>" & Worksheets("Data").Cells(i, "G").Value & "</b>" _
        & " and next due date is " & "<b>" & Worksheets("Data").Cells(i, "H").Value & "</b>" & ".<br><br>" _
        & "Kindly do the calibration on time for accurate batching.<br><br>" & S

        
        On Error Resume Next
        With OutMail
        .To = toList
        .CC = CCList
        .BCC = ""
        .Subject = eSubject
        .HTMLBody = eBody
        .Display   ' ********* Creates draft emails. Comment this out when you are ready
        '.Send     '********** UN-comment this when you  are ready to go live
        End With
 
    On Error GoTo 0
    Set OutMail = Nothing
 Cells(i, 10) = "Reminder Sent on " & Date  'Marks the row as "email sent in Column A"
End If
Next i

Set OutApp = Nothing

ActiveWorkbook.Save

With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .DisplayAlerts = True
End With
Sheets("Data").Range("A1").Select
End Sub

Display More

**royUK** · Apr 20th 2020

Thanks for posting your working code. I have had a look and the code below is based on it, but removes the nee to slect the sheet plus a couple of other alterations.

Code

Sub Remindermail()
Dim lRow As Integer
Dim i As Integer
Dim toDate As Date
Dim toList, CCList As String
Dim eSubject As String
Dim eBody As String
Dim OutApp As Object, _
OutMail As Object
Dim Signature As String
Dim sPath As String
Dim S As String
Dim sht As Worksheet


With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False




Set sht = Sheets("Data")


On Error GoTo err_exit


With sht
lRow = .Cells(.Rows.Count, 4).End(xlUp).Row


Set OutApp = CreateObject("Outlook.Application")


S = Environ("appdata") & "\Microsoft\Signatures\"
If Dir(S, vbDirectory) <> vbNullString Then S = S & Dir$(S & "*.htm") Else S = ""
S = CreateObject("Scripting.FileSystemObject").GetFile(S).OpenAsTextStream(1, -2).ReadAll


For i = 4 To lRow
If .Cells(i, 9).Value >= 1 And .Cells(i, 9).Value <= 10 And .Cells(i, 10).Value = "" Then
Set OutMail = OutApp.CreateItem(0)
toList = .Cells(i, 4)    'gets the recipient from col B
'CCList = Cells(i, 8) & ", " & Cells(i, 9) & ", " & Cells(i, 10)
eSubject = "Calibration remainder for your " & .Cells(i, 5) & " Batching Plant "
eBody = "<font style=""font-family:Cambria; font-size:12pt;""/font> Dear Sir, <br><br>" _
& "Greetings from " & "<b> SCHWING STETTER! </b><br><br>" _
& "Your " & "<b>" & Worksheets("Data").Cells(i, "E").Value & "</b>" _
& " Batching Plant calibration certificate is going to expire soon ( within " _
& "<b>" & .Cells(i, "I").Value & "</b>" & " days ).<br><br>" _
& "Plant Last calibration done date is " & "<b>" & .Cells(i, "G").Value & "</b>" _
& " and next due date is " & "<b>" & .Cells(i, "H").Value & "</b>" & ".<br><br>" _
& "Kindly do the calibration on time for accurate batching.<br><br>" & S




On Error Resume Next
With OutMail
.To = toList
.CC = CCList
.BCC = ""
.Subject = eSubject
.HTMLBody = eBody
.Display    ' ********* Creates draft emails. Comment this out when you are ready
'.Send '********** UN-comment this when you are ready to go live
End With


On Error GoTo 0
Set OutMail = Nothing
.Cells(i, 10) = "Reminder Sent on " & Date    'Marks the row as "email sent in Column A"
End If
Next i
End With
Set OutApp = Nothing


ActiveWorkbook.Save


err_exit:


.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
Sheets("Data").Range("A1").Select
End Sub

Display More

elsuji · Apr 20th 2020

Dear Roy,

Thanks for posting.

I have one more problem on this code. In ebody i wrote code for default font size is 12pt. But when i am running this code on my outlook the font is updated 11 only.

I tried with 10, 13 ,14 & 15. All are updating properly on outlook. But Only 12 is not updating,

This problem already posted on this forum

Outlook Mail body font size problem

Can you please check and update me where the mistake is happen

**royUK** · Apr 20th 2020

The problem is in the html section of the code. I don't code html so I caan't help.

elsuji · Apr 20th 2020

ok mr. Roy

Send Outlook Mail based on value changes in cell

Participate now!

Share