Email alerts with an expire date

[lil16]

I am looking for a way to receive e-mail alerts when an expiry date is approaching. This date would be located in a cell in excel. Would like to have 6 month, 3 month and 1 month warnings.

Thank you!!!

 

[bugmonsta]

Hi lil16, here is a quick (may not be the best) code that I think will get you on the right path:

this code I have set in the Activesheet but I would recommend you set this on workbook open so it only fires once each time you open the file.

This code checks the date in sheet1 cell A1, this can be changed to your requirements. It then checks if B1 has the text "Email Generated 1 3 or 6" as we don't want to fire the same reminder if it has already been done

This code checks the date from today to the date, if its -1 then its one month, -3 three months etc

Private Sub Worksheet_Activate()

Dim sheetdate, tday As Date
Dim edate As Long
Dim msgdate As String
msgdate = "" 'ensure this is nothing

sheetdate = Format(Sheet1.Range("A1").Value, "dd-mm-yy") ' take the date from cell A1 in sheet1 (rename if your using another sheet/or name), and format it in the style you require

tday = Format(Now(), "dd-mm-yy") 'format today into the date format you require
edate = DateDiff("m", sheetdate, tday) ' work out the date difference in months

If ActiveSheet.Range("B1").Value <> "Email Generated1" Then
If edate = "-1" Then 'if the month is less one month then fire this code
msgdate = "ONE"
Call Mail(msgdate)
Sheet1.Range("b1").Value = "Email Generated1" ' set a value so it does not trigger again
End If
End If

If ActiveSheet.Range("B1").Value <> "Email Generated3" Then
If edate = "-3" Then 'if the month is less one month then fire this code
msgdate = "THREE"
Call Mail(msgdate)
Sheet1.Range("b1").Value = "Email Generated3"  ' set a value so it does not trigger again
End If
End If

If ActiveSheet.Range("B1").Value <> "Email Generated6" Then
If edate = "-6" Then 'if the month is less one month then fire this code
msgdate = "SIX"
Call Mail(msgdate)
Sheet1.Range("b1").Value = "Email Generated6"  ' set a value so it does not trigger again
End If
End If


End Sub

This next set of code is some email code (placed into a module) based on https://www.rondebruin.nl/win/s1/outlook/mail.htm, and it just displays an email depending if its one, three or six months. You can change this to just send so the person does not know this has been done, but I have left it as display so you can see/edit the message until you are happy

hope it all makes sense

Sub Mail(msgdate)
If msgdate = "" Then Exit Sub 'quit if not variable set

    Dim OutApp As Object
    Dim OutMail As Object
    Dim strbody, subline, bodytxt, sname, carbon, ename As String
    Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
    sname = ActiveWorkbook.Name
    carbon = ""
    ename = "THIS IS YOUR EMAIL ADDRESS"
    
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)



If msgdate = "SIX" Then
strbody = "****** style=font-size:10pt;font-family:Arial>" & "Dear Someone" & "," & "<br> <br>" _
& sname & " has hit its 6 month expiry warning, do something"

   subline = "SIX Month Expiry warning for " & sname
   
    sensr = 1
    On Error Resume Next
    readr = True
    deliverr = False
End If

If msgdate = "THREE" Then
strbody = "****** style=font-size:10pt;font-family:Arial>" & "Dear Someone" & "," & "<br> <br>" _
& sname & " has hit its 3 month expiry warning, do something"

   subline = "THREE Month Expiry warning for " & sname
   
    sensr = 1
    On Error Resume Next
    readr = True
    deliverr = False
End If


If msgdate = "ONE" Then
strbody = "****** style=font-size:10pt;font-family:Arial>" & "Dear Someone" & "," & "<br> <br>" _
& sname & " has hit its 1 month expiry warning, do something"

   subline = "WARNING - ONE Month Expiry warning for " & sname & " WHOOP! WHOOP! WARNING!"
   
    sensr = 1
    On Error Resume Next
    readr = True
    deliverr = False
End If



    With OutMail
    
        .To = ename
        .cc = carbon
        .BCC = ""
        .Subject = subline
        .HTMLBody = strbody
        .Importance = 2
        .ReadReceiptRequested = readr
        .OriginatorDeliveryReportRequested = deliverr
        .Sensitivity = sensr
        
         
        .Display    'or use .send
    End With
    On Error GoTo 0
    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub