sathishsusa
06-02-2017, 05:09 PM
Hi,
i need to send reminder email to outlook automatically if due date reaches before 30 days and 15 days in expiry date column " F & K" .
Each employee having two cards (Driving card and License card) if any one cards expiry soon then send reminder email to the client and cc to others and date of email send to be register in column "H, I, M, N" of 15 and 30 days. please refer the attachment for more information.
The cross posted link:https://www.excelforum.com/excel-programming-vba-macros/1187299-send-reminder-email-if-cell-value-reached-by-selective-case-through-outlook-mail.html#post4667575
so far Mr.SyracuseWolvrine his given the code but its only working by separate sub module of 15 and 30 days. Now i need to modify the code into one module to send email to client and once email has been register in column "H, I, M, N". i don't need to send email again to client. please if possible you can change to your own any other idea to get the results or change in column also ok for me.Further i you need any other information or clarification on this please let me know.
one more thing i don't have any knowledge about the HTML tag Code to get the color on table in outlook.
please Experts help me to solve this problems.
Sub Check15SendEmail()Dim date15 As Date
Dim toName As String
Dim toEmail As String
Dim dCardIssueDate As Date
Dim dCardExprDate As Date
Dim dCardStatus As String
Dim appOutlook As Object
Dim MailItem As Object
Dim mailbodytext As String
Dim ccEmail As String
Dim idnum As String
Dim dept As String
Dim rownum As Integer
date15 = Sheets("Sheet1").Range("Q5").Value
'Scroll through all rows and do the email process if they are near expiration
' rownum starts at 5 because that is the first row with data
' I chose to end it at 7 as this is the last row with all data
For rownum = 5 To 50
'check to see if date is within 15 days
If Sheets("Sheet1").Range("F" & rownum) < date15 Then
'If Sheets("Sheet1").Range("F" & rownum) < date15 Then
'if so, do the email
toName = Sheets("Sheet1").Range("A" & rownum).Value
toEmail = Sheets("Sheet1").Range("C" & rownum).Value
idnum = Sheets("Sheet1").Range("B" & rownum).Value
dept = Sheets("Sheet1").Range("D" & rownum).Value
dCardIssueDate = Sheets("Sheet1").Range("E" & rownum).Value
dCardExprDate = Sheets("Sheet1").Range("F" & rownum).Value
dCardStatus = Sheets("Sheet1").Range("G" & rownum).Value
mybodytext = "<p>Dear " & toName & ",<br />"
mybodytext = mybodytext & "<br />This is to remind you that your card is going to be expiring soon. Kindly arrange to renew your card as soon as possible.<br />"
mybodytext = mybodytext & "<table border=""1""><tr><td>Name</td><td>ID No</td><td>Email ID</td><td>Department</td><td>Driving Card Issue Date</td><td>Driving Card Expiry Date</td><td>Status</td></tr>"
mybodytext = mybodytext & "<tr><td>" & toName & "</td><td>" & idnum & "</td><td>" & toEmail & "</td><td>" & dept & "</td><td>" & dCardIssueDate & "</td><td>" & dCardExprDate & "</td><td>" & dCardStatus & "</td></tr>"
mybodytext = mybodytext & "</table><br />Regards,"
Set appOutlook = GetObject(, "Outlook.Application")
Set MailItem = appOutlook.CreateItem(0)
MailItem.htmlbody = mybodytext
MailItem.To = toEmail
MailItem.Subject = "Your Driving Card Expiry Date is less than 15 days"
MailItem.Display
Sheets("Sheet1").Range("I" & rownum).Value = Now()
End If
Next rownum
Set appOutlook = Nothing
Set MailItem = Nothing
End Sub
Sub Check30SendEmail()
Dim date30 As Date
Dim toName As String
Dim toEmail As String
Dim dCardIssueDate As Date
Dim dCardExprDate As Date
Dim dCardStatus As String
Dim appOutlook As Object
Dim MailItem As Object
Dim mailbodytext As String
Dim ccEmail As String
Dim idnum As String
Dim dept As String
Dim rownum As Integer
date30 = Sheets("Sheet1").Range("Q6").Value
'Scroll through all rows and do the email process if they are near expiration
' rownum starts at 5 because that is the first row with data
' I chose to end it at 7 as this is the last row with all data
For rownum = 5 To 50
'check to see if date is within 15 days
If Sheets("Sheet1").Range("F" & rownum) < date30 Then
'if so, do the email
toName = Sheets("Sheet1").Range("A" & rownum).Value
toEmail = Sheets("Sheet1").Range("C" & rownum).Value
idnum = Sheets("Sheet1").Range("B" & rownum).Value
dept = Sheets("Sheet1").Range("D" & rownum).Value
dCardIssueDate = Sheets("Sheet1").Range("E" & rownum).Value
dCardExprDate = Sheets("Sheet1").Range("F" & rownum).Value
dCardStatus = Sheets("Sheet1").Range("G" & rownum).Value
mybodytext = "<p>Dear " & toName & ",<br />"
mybodytext = mybodytext & "<br />This is to remind you that your card is going to be expiring soon. Kindly arrange to renew your card as soon as possible.<br />"
mybodytext = mybodytext & "<table border=""1""><tr><td>Name</td><td>ID No</td><td>Email ID</td><td>Department</td><td>Driving Card Issue Date</td><td>Driving Card Expiry Date</td><td>Status</td></tr>"
mybodytext = mybodytext & "<tr><td>" & toName & "</td><td>" & idnum & "</td><td>" & toEmail & "</td><td>" & dept & "</td><td>" & dCardIssueDate & "</td><td>" & dCardExprDate & "</td><td>" & dCardStatus & "</td></tr>"
mybodytext = mybodytext & "</table><br />Regards,"
Set appOutlook = GetObject(, "Outlook.Application")
Set MailItem = appOutlook.CreateItem(0)
MailItem.htmlbody = mybodytext
MailItem.To = toEmail
MailItem.Subject = "Your Driving Card Expiry Date is less than 30 days"
MailItem.Display
Sheets("Sheet1").Range("H" & rownum).Value = Now()
End If
Next rownum
Set appOutlook = Nothing
Set MailItem = Nothing
End Sub
i need to send reminder email to outlook automatically if due date reaches before 30 days and 15 days in expiry date column " F & K" .
Each employee having two cards (Driving card and License card) if any one cards expiry soon then send reminder email to the client and cc to others and date of email send to be register in column "H, I, M, N" of 15 and 30 days. please refer the attachment for more information.
The cross posted link:https://www.excelforum.com/excel-programming-vba-macros/1187299-send-reminder-email-if-cell-value-reached-by-selective-case-through-outlook-mail.html#post4667575
so far Mr.SyracuseWolvrine his given the code but its only working by separate sub module of 15 and 30 days. Now i need to modify the code into one module to send email to client and once email has been register in column "H, I, M, N". i don't need to send email again to client. please if possible you can change to your own any other idea to get the results or change in column also ok for me.Further i you need any other information or clarification on this please let me know.
one more thing i don't have any knowledge about the HTML tag Code to get the color on table in outlook.
please Experts help me to solve this problems.
Sub Check15SendEmail()Dim date15 As Date
Dim toName As String
Dim toEmail As String
Dim dCardIssueDate As Date
Dim dCardExprDate As Date
Dim dCardStatus As String
Dim appOutlook As Object
Dim MailItem As Object
Dim mailbodytext As String
Dim ccEmail As String
Dim idnum As String
Dim dept As String
Dim rownum As Integer
date15 = Sheets("Sheet1").Range("Q5").Value
'Scroll through all rows and do the email process if they are near expiration
' rownum starts at 5 because that is the first row with data
' I chose to end it at 7 as this is the last row with all data
For rownum = 5 To 50
'check to see if date is within 15 days
If Sheets("Sheet1").Range("F" & rownum) < date15 Then
'If Sheets("Sheet1").Range("F" & rownum) < date15 Then
'if so, do the email
toName = Sheets("Sheet1").Range("A" & rownum).Value
toEmail = Sheets("Sheet1").Range("C" & rownum).Value
idnum = Sheets("Sheet1").Range("B" & rownum).Value
dept = Sheets("Sheet1").Range("D" & rownum).Value
dCardIssueDate = Sheets("Sheet1").Range("E" & rownum).Value
dCardExprDate = Sheets("Sheet1").Range("F" & rownum).Value
dCardStatus = Sheets("Sheet1").Range("G" & rownum).Value
mybodytext = "<p>Dear " & toName & ",<br />"
mybodytext = mybodytext & "<br />This is to remind you that your card is going to be expiring soon. Kindly arrange to renew your card as soon as possible.<br />"
mybodytext = mybodytext & "<table border=""1""><tr><td>Name</td><td>ID No</td><td>Email ID</td><td>Department</td><td>Driving Card Issue Date</td><td>Driving Card Expiry Date</td><td>Status</td></tr>"
mybodytext = mybodytext & "<tr><td>" & toName & "</td><td>" & idnum & "</td><td>" & toEmail & "</td><td>" & dept & "</td><td>" & dCardIssueDate & "</td><td>" & dCardExprDate & "</td><td>" & dCardStatus & "</td></tr>"
mybodytext = mybodytext & "</table><br />Regards,"
Set appOutlook = GetObject(, "Outlook.Application")
Set MailItem = appOutlook.CreateItem(0)
MailItem.htmlbody = mybodytext
MailItem.To = toEmail
MailItem.Subject = "Your Driving Card Expiry Date is less than 15 days"
MailItem.Display
Sheets("Sheet1").Range("I" & rownum).Value = Now()
End If
Next rownum
Set appOutlook = Nothing
Set MailItem = Nothing
End Sub
Sub Check30SendEmail()
Dim date30 As Date
Dim toName As String
Dim toEmail As String
Dim dCardIssueDate As Date
Dim dCardExprDate As Date
Dim dCardStatus As String
Dim appOutlook As Object
Dim MailItem As Object
Dim mailbodytext As String
Dim ccEmail As String
Dim idnum As String
Dim dept As String
Dim rownum As Integer
date30 = Sheets("Sheet1").Range("Q6").Value
'Scroll through all rows and do the email process if they are near expiration
' rownum starts at 5 because that is the first row with data
' I chose to end it at 7 as this is the last row with all data
For rownum = 5 To 50
'check to see if date is within 15 days
If Sheets("Sheet1").Range("F" & rownum) < date30 Then
'if so, do the email
toName = Sheets("Sheet1").Range("A" & rownum).Value
toEmail = Sheets("Sheet1").Range("C" & rownum).Value
idnum = Sheets("Sheet1").Range("B" & rownum).Value
dept = Sheets("Sheet1").Range("D" & rownum).Value
dCardIssueDate = Sheets("Sheet1").Range("E" & rownum).Value
dCardExprDate = Sheets("Sheet1").Range("F" & rownum).Value
dCardStatus = Sheets("Sheet1").Range("G" & rownum).Value
mybodytext = "<p>Dear " & toName & ",<br />"
mybodytext = mybodytext & "<br />This is to remind you that your card is going to be expiring soon. Kindly arrange to renew your card as soon as possible.<br />"
mybodytext = mybodytext & "<table border=""1""><tr><td>Name</td><td>ID No</td><td>Email ID</td><td>Department</td><td>Driving Card Issue Date</td><td>Driving Card Expiry Date</td><td>Status</td></tr>"
mybodytext = mybodytext & "<tr><td>" & toName & "</td><td>" & idnum & "</td><td>" & toEmail & "</td><td>" & dept & "</td><td>" & dCardIssueDate & "</td><td>" & dCardExprDate & "</td><td>" & dCardStatus & "</td></tr>"
mybodytext = mybodytext & "</table><br />Regards,"
Set appOutlook = GetObject(, "Outlook.Application")
Set MailItem = appOutlook.CreateItem(0)
MailItem.htmlbody = mybodytext
MailItem.To = toEmail
MailItem.Subject = "Your Driving Card Expiry Date is less than 30 days"
MailItem.Display
Sheets("Sheet1").Range("H" & rownum).Value = Now()
End If
Next rownum
Set appOutlook = Nothing
Set MailItem = Nothing
End Sub