Tech Support Guy banner
Status
Not open for further replies.

Send email reminder for due date (Hans Module)

1K views 6 replies 3 participants last post by  fgraham 
#1 ·
Hello,

I was able to successfully apply Hans' module and have the spreadsheet send an email when it was opened if something was out of the calibration date.

My question is now if it is possible to have it send 2 weeks in advance, and then again in 1 week later. I know that because the cell will be occupied that it was initially sent, it will not read it again for another send. Is there a way to automatically clear a column so that it just sends an email every time its opened within that range?

Finally, where do I add the column for a CC email?

Code:
Option Explicit

Public Sub eMail()
Dim lRow    As Integer
Dim i       As Integer
Dim toDate  As Date
Dim toList  As String
Dim eSubject    As String
Dim EBody   As String
Dim ws      As Worksheet
With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .DisplayAlerts = False
End With
Set ws = Sheets("Master Equipment LIST")
Sheets(1).Select
lRow = WorksheetFunction.Max(3, ws.Cells(Rows.Count, "K").End(xlUp).Row)
If ws.Cells(lRow, "K").Value = "" Then Exit Sub
For i = 2 To lRow
    toDate = Replace(Cells(i, "K"), ".", "/")
    Debug.Print WorksheetFunction.Days360(Date, ws.Cells(i, "K").Value)
    If WorksheetFunction.Days360(Date, ws.Cells(i, "K").Value) <= 14 And Len(Trim(ws.Cells(i, "M").Value)) = 0 Then
'    If Left(Cells(i, 5), 4) <> "Mail" And toDate - Date <= 30 Then
        toList = Cells(i, "X")    'gets the recipient from col D
        eSubject = "Entry # " & Cells(i, "A").Value & " is due on " & Cells(i, "K").Value
        EBody = "Mr. " & Cells(i, "Y") & vbCrLf & vbCrLf & "Calibration For The Above Listed Entry is Due"
        Call MailData(eSubject, EBody, toList)
        ws.Cells(i, "M").Value = "Mail Sent " & Now()    'Marks the row as "email sent in Column P"
    End If
Next i
ActiveWorkbook.Save
With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .DisplayAlerts = True
End With
End Sub

Function MailData(mSubject As String, mMessage As String, Sendto As String, Optional CCto As String)
Dim app As Object, Itm As Variant
Set app = CreateObject("Outlook.Application")
Set Itm = app.CreateItem(0)

With Itm
    .Subject = mSubject
    .To = Sendto
    If Not IsMissing(CCto) Then .CC = CCto
    .Body = mMessage
'     .Attachments.Add (NewFileName1) ' Must be complete path
    .Display        ' activate this property when you want to view the message before sending
'    .Save           ' activate this property to save the message as Draft
'    .Send          ' activate this one to send directly
End With
Set app = Nothing
Set Itm = Nothing
End Function
 
See less See more
#2 · (Edited)
I was able to make the code send an email for a range, from anything greater than 7 days and less than 14, or anything less than 7.

My only remaining question is if it is possible for it to send a second reminder for those that are less than 7 days but have already fallen into the first category of between 7 and 14 days?

I also realized to do the CC operation you just replace the CCto in the code above with your email. Thank you Hans for this code!

Code:
Option Explicit

Public Sub eMail()
Dim lRow    As Integer
Dim i       As Integer
Dim toDate  As Date
Dim toList  As String
Dim eSubject    As String
Dim EBody   As String
Dim ws      As Worksheet
With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .DisplayAlerts = False
End With
Set ws = Sheets("Master Equipment LIST")
Sheets(1).Select
lRow = WorksheetFunction.Max(3, ws.Cells(Rows.Count, "K").End(xlUp).Row)
If ws.Cells(lRow, "K").Value = "" Then Exit Sub
For i = 2 To lRow
    toDate = Replace(Cells(i, "K"), ".", "/")
    Debug.Print WorksheetFunction.Days360(Date, ws.Cells(i, "K").Value)
    If WorksheetFunction.Days360(Date, ws.Cells(i, "K").Value) > 7 And WorksheetFunction.Days360(Date, ws.Cells(i, "K").Value) <= 14 And Len(Trim(ws.Cells(i, "M").Value)) = 0 Then
'    If Left(Cells(i, 5), 4) <> "Mail" And toDate - Date <= 30 Then
        toList = Cells(i, "X")    'gets the recipient from col D
        eSubject = "Entry # " & Cells(i, "A").Value & " is due on " & Cells(i, "K").Value
        EBody = "Mr. " & Cells(i, "Y") & vbCrLf & vbCrLf & "Calibration For The Above Listed Entry is Due"
        Call MailData(eSubject, EBody, toList)
        ws.Cells(i, "M").Value = "Mail Sent " & Now()    'Marks the row as "email sent in Column P"
    End If
Next i
For i = 2 To lRow
    toDate = Replace(Cells(i, "K"), ".", "/")
    Debug.Print WorksheetFunction.Days360(Date, ws.Cells(i, "K").Value)
    If WorksheetFunction.Days360(Date, ws.Cells(i, "K").Value) <= 7 And WorksheetFunction.Days360(Date, ws.Cells(i, "K").Value) <= 14 And Len(Trim(ws.Cells(i, "M").Value)) = 0 Then
'    If Left(Cells(i, 5), 4) <> "Mail" And toDate - Date <= 30 Then
        toList = Cells(i, "X")    'gets the recipient from col D
        eSubject = "Entry # " & Cells(i, "A").Value & " is due on " & Cells(i, "K").Value
        EBody = "Mr. " & Cells(i, "Y") & vbCrLf & vbCrLf & "Calibration For The Above Listed Entry is Due"
        Call MailData(eSubject, EBody, toList)
        ws.Cells(i, "M").Value = "Mail Sent " & Now()    'Marks the row as "email sent in Column P"
    End If
Next i
ActiveWorkbook.Save
With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .DisplayAlerts = True
End With
End Sub

Function MailData(mSubject As String, mMessage As String, Sendto As String, Optional CCto As String)
Dim app As Object, Itm As Variant
Set app = CreateObject("Outlook.Application")
Set Itm = app.CreateItem(0)

With Itm
    .Subject = mSubject
    .To = Sendto
    If Not IsMissing(CCto) Then .CC = "xxxx@email.com"
    .Body = mMessage
'     .Attachments.Add (NewFileName1) ' Must be complete path
    .Display        ' activate this property when you want to view the message before sending
'    .Save           ' activate this property to save the message as Draft
'    .Send          ' activate this one to send directly
End With
Set app = Nothing
Set Itm = Nothing
End Function
 
#3 ·
Hi, you're welcome.
You can always add another column for the final reminder and check if the previous one has been filled to do the next task.
It's just a question of setting the date calculation in days to what you want.
BTW the CCTo parameter you can pass a parametr, by hardocding it now like you've done you restrict yourself.
 
#4 · (Edited)
Hi Hans,

I was going to use another column, and if the scan found it to be 14 days or less it would fill one column, and 7 days or less it would fill another, and thus two emails would be sent.

I got it all to work out, here is the code if anyone else needs it, thank you again!

Code:
Option Explicit

Public Sub eMail()
Dim lRow    As Integer
Dim i       As Integer
Dim toDate  As Date
Dim toList  As String
Dim eSubject    As String
Dim EBody   As String
Dim ws      As Worksheet
With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .DisplayAlerts = False
End With
Set ws = Sheets("Master Equipment LIST")
Sheets(1).Select
lRow = WorksheetFunction.Max(3, ws.Cells(Rows.Count, "K").End(xlUp).Row)
If ws.Cells(lRow, "K").Value = "" Then Exit Sub
For i = 2 To lRow
    toDate = Replace(Cells(i, "K"), ".", "/")
    Debug.Print WorksheetFunction.Days360(Date, ws.Cells(i, "K").Value)
    If WorksheetFunction.Days360(Date, ws.Cells(i, "K").Value) > 7 And WorksheetFunction.Days360(Date, ws.Cells(i, "K").Value) <= 14 And Len(Trim(ws.Cells(i, "M").Value)) = 0 Then
'    If Left(Cells(i, 5), 4) <> "Mail" And toDate - Date <= 30 Then
        toList = Cells(i, "Y")    'gets the recipient from col D
        eSubject = "Entry # " & Cells(i, "A").Value & " is due on " & Cells(i, "K").Value
        EBody = "Mr. " & Cells(i, "Z") & vbCrLf & vbCrLf & "Calibration For The Above Listed Entry is Due in 14 days or less"
        Call MailData(eSubject, EBody, toList)
        ws.Cells(i, "M").Value = "14 Days Or Less " 'Marks the row as "email sent in Column P"
        ws.Cells(i, "M").Interior.ColorIndex = 45
    End If
Next i
For i = 2 To lRow
    toDate = Replace(Cells(i, "K"), ".", "/")
    Debug.Print WorksheetFunction.Days360(Date, ws.Cells(i, "K").Value)
    If WorksheetFunction.Days360(Date, ws.Cells(i, "K").Value) <= 7 And WorksheetFunction.Days360(Date, ws.Cells(i, "K").Value) <= 14 And Len(Trim(ws.Cells(i, "N").Value)) = 0 Then
'    If Left(Cells(i, 5), 4) <> "Mail" And toDate - Date <= 30 Then
        toList = Cells(i, "Y")    'gets the recipient from col D
        eSubject = "Entry # " & Cells(i, "A").Value & " is due on " & Cells(i, "K").Value
        EBody = "Mr. " & Cells(i, "Z") & vbCrLf & vbCrLf & "Calibration For The Above Listed Entry is Due in 7 days or less"
        Call MailData(eSubject, EBody, toList)
        ws.Cells(i, "N").Value = "7 Days Or Less "   'Marks the row as "email sent in Column P"
        ws.Cells(i, "N").Interior.ColorIndex = 3
    End If
Next i
ActiveWorkbook.Save
With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .DisplayAlerts = True
End With
End Sub

Function MailData(mSubject As String, mMessage As String, Sendto As String, Optional CCto As String)
Dim app As Object, Itm As Variant
Set app = CreateObject("Outlook.Application")
Set Itm = app.CreateItem(0)

With Itm
    .Subject = mSubject
    .To = Sendto
    If Not IsMissing(CCto) Then .CC = "JRamirez@tensysmedical.com"
    .Body = mMessage
'     .Attachments.Add (NewFileName1) ' Must be complete path
    .Display        ' activate this property when you want to view the message before sending
'    .Save           ' activate this property to save the message as Draft
'    .Send          ' activate this one to send directly
End With
Set app = Nothing
Set Itm = Nothing
End Function
 
#5 ·
The reason it returns False is because you are placing a result in that cell not a value
Literally you're asking if the text in that cell ="14 Days Or Less" AND if the color = whatever the value for 45 is.
Well the answer is NO so FALSE
What you have to do is:

Code:
If bla  bla bal then 
    ws.Cells(i, "M").Value = "14 Days Or Less " 
   ws.Cells(i, "M").Interior.ColorIndex = 45
End if
Hope you get the idea :)
 
Status
Not open for further replies.
You have insufficient privileges to reply here.
Top