• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Automatic send Reminder Email if Due date Approching

S

sathishsusa

Member
Hi,

i want to send reminder email to client via outlook if due date is reaching before 30 and 15 days.
once mail send to the client then date to be registered in column "H, I" of 15 and 30 days.
The code which is working by separate module of 15 and 30 days working fine and i tried to make in one module but i became failure. please can anyone help me to modify the code into one module to send the email once workbook is open. i am waiting for long time to solve this problems but i didn't get no any positive results. please my humble request any help at all would be much appreciated!

Thanks for looking and for your time. if any further additional details need on this file please let me know i will provide you sir.

Code: 
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 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
 

Attachments

  • Remainder email checking.xlsm
    33.8 KB · Views: 24
Hi, sathishsusa!

This isn't the solution you're asking for, it's just a general guideline for a DIY task.

Since you can't join both procedures I assume that you're not the author, so try to be very careful with the modifications:
- copy one of the procedures and name it Check1530SendEmail
- add a declaration for other date variable (date30 if you copied the 15th, date15 if you copied the 30th)
- add declarations for two other boolean variables: b15 and b30
- copy the definition of the added date from the non copied procedure and place it just below the existing (date15 or date30 = .... Q5/Q6 cell)
- duplicate the existing if checking condition, one below the other, one for date15 and the other for date30
- add at the end of the date15 one: "...then b15=true"
- add at the end of the date30 one: "...then b30=true"
- add just below a new "if" clause for checking both conditions, like "if b15 or b30 then"
- change the definition of the "MailItem.Subject" to something like:
"MailItem.Subject=Your Driving Card Expiry Date is less than "
- add these lines just below:
if b30 then
MailItem.Subject=MailItemSubject & "30" & "days"
else
MailItem.Subject=MailItemSubject & "15" & "days"
endif

Run it and enjoy.

Regards!
 
Hi SirJB7,

Finally i am very happy that i got the reply thank you sir.

You are right sir, i am not the author of this code i just got the guidelines sample code try to solve but Now i'am getting more clarity of work after you explained to me i will give a try to solve based on your given steps and come back to you

Many Thanks,
 
Dear Sathisusa,

This logic will help for my work as well. Can you give the updated code where i can use for my work.
 
SirJB7 said:
Hi, sathishsusa!

This isn't the solution you're asking for, it's just a general guideline for a DIY task.

Since you can't join both procedures I assume that you're not the author, so try to be very careful with the modifications:
- copy one of the procedures and name it Check1530SendEmail
- add a declaration for other date variable (date30 if you copied the 15th, date15 if you copied the 30th)
- add declarations for two other boolean variables: b15 and b30
- copy the definition of the added date from the non copied procedure and place it just below the existing (date15 or date30 = .... Q5/Q6 cell)
- duplicate the existing if checking condition, one below the other, one for date15 and the other for date30
- add at the end of the date15 one: "...then b15=true"
- add at the end of the date30 one: "...then b30=true"
- add just below a new "if" clause for checking both conditions, like "if b15 or b30 then"
- change the definition of the "MailItem.Subject" to something like:
"MailItem.Subject=Your Driving Card Expiry Date is less than "
- add these lines just below:
if b30 then
MailItem.Subject=MailItemSubject & "30" & "days"
else
MailItem.Subject=MailItemSubject & "15" & "days"
endif

Run it and enjoy.

Regards!
Click to expand...


There is some updated code its just working fine but It's only an issue the first times when ever run the macro.

The first time when i run it, it'll generate the 15 day emails. The next time, it'll see that the 15 day email has already been sent and skip ahead to check for the 30 day email.

Now what i need how can i check the loop first send the 30 days email and skip ahead to check for the 15 days email.

i need to some loop correction on my code please can you help me to solve this problems.

Code: 
Sub DrivingCard()
Dim date15 As Date
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
Dim whichEmail As Integer
Dim day15Email As String
Dim day15Subj As String
Dim day30Email As String
Dim day30Subj As String
Dim doTheEmail As Boolean

date15 = Sheets("Sheet1").Range("Q5").Value
date30 = Sheets("Sheet1").Range("Q6").Value

day30Subj = "Driving Card Expires in 30 days"
day15Subj = "Driving Card Expires in 15 days - Second EMail"

'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

    doTheEmail = False
    whichEmail = 0

    'check to see if the date is within 30 days and ensure that a 30 day email has not yet been sent
    If (Sheets("Sheet1").Range("F" & rownum) < date30) And (Sheets("Sheet1").Range("H" & rownum) = "") Then
        whichEmail = 30
        doTheEmail = True
    End If

    'check to see if date is within 15 days and ensure that a 15 day email has not yet been sent
    If (Sheets("Sheet1").Range("F" & rownum) < date15) And (Sheets("Sheet1").Range("I" & rownum) = "") Then
        whichEmail = 15
        doTheEmail = True
    End If

    If doTheEmail = True Then
        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
   
        mailbodytext = "<p>Dear " & toName & ",<br />"
        mailbodytext = mailbodytext & "<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 />"
        mailbodytext = mailbodytext & "<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>"
        mailbodytext = mailbodytext & "<tr><td>" & toName & "</td><td>" & idnum & "</td><td>" & toEmail & "</td><td>" & dept & "</td><td>" & dCardIssueDate & "</td><td>" & dCardExprDate & "</td><td>" & dCardStatus & "</td></tr>"
        mailbodytext = mailbodytext & "</table><br />Regards,"
   
        Set appOutlook = GetObject(, "Outlook.Application")
        Set MailItem = appOutlook.CreateItem(0)
   
        MailItem.htmlbody = mailbodytext
        MailItem.To = toEmail
       
        'set the subject and fill in the date that the email was sent, based on which email it is
        If whichEmail = 15 Then
            MailItem.Subject = day15Subj
            Sheets("Sheet1").Range("I" & rownum).Value = Now()
        End If
       
        If whichEmail = 30 Then
            MailItem.Subject = day30Subj
            Sheets("Sheet1").Range("H" & rownum).Value = Now()
        End If
        MailItem.Display

End If

Next rownum

Set appOutlook = Nothing
Set MailItem = Nothing

End Sub
 
You must log in or register to reply here.
Back
Top