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?
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