I am trying to send out emails based on a due date on my excel sheet. I have a list of items in which each item has a specific owner, the description of that item and a due date for that item.
The recepients of the item are in column "F" and the due date is in column "R". Here is the code that I have so far but I am getting an error stating that there is a Runtime error 13 and Type Mismatch. The code runs fine for a little while and then I start receiving this error. When I have multiple due dates, that is when this error occurs. I am not sure what I am doing wrong. If there is any way I can edit the code please propose it, or if there is another way about sending emails out based on a due date, please let me know the code. I will specify where in the code there is an error.
Thank you!
Public Sub CheckAndSendMail()
Dim lRow As Long
Dim lstRow As Long
Dim toDate As Date
Dim toList As String
Dim ccList As String
Dim bccList As String
Dim eSubject As String
Dim EBody As String
Dim vbCrLf As String
Dim ws As Worksheet
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With
Set ws = Sheets(1)
ws.Select
lstRow = WorksheetFunction.Max(3, ws.Cells(Rows.Count, "R").End(xlUp).Row)
For lRow = 3 To lstRow
'THIS IS WHERE I RECEIVE THE ERROR:
toDate = Cells(lRow, "R").Value
'toDate = Replace(Cells(lRow, "L"), ".", "/")
If Left(Cells(lRow, "R"), 17) <> "Mail" And toDate - Date <= 7 Then
vbCrLf = "<br><br>"
toList = Cells(lRow, "F") 'gets the recipient from col F
eSubject = "Text" & Cells(lRow, "C") & " is due on " & Cells(lRow, "R").Value
EBody = "<HTML><BODY>"
EBody = EBody & "Dear " & Cells(lRow, "F").Value & vbCrLf
EBody = EBody & "Text" & Cells(lRow, "C").Value & vbCrLf
EBody = EBody & "Text" & vbCrLf
EBody = EBody & "Link to the Document:"
EBody = EBody & "<A href='Link to Document'>Text </A>"
EBody = EBody & "</BODY></HTML>"
Cells(lRow, "W") = "Mail Sent " & Date + Time 'Marks the row as "email sent in Column W"
MailData msgSubject:=eSubject, msgBody:=EBody, Sendto:=toList
End If
Next lRow
ActiveWorkbook.Save
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
End Sub
Function MailData(msgSubject As String, msgBody As String, Sendto As String, _
Optional CCto As String, Optional BCCto As String, Optional fAttach As String)
Dim app As Object, Itm As Variant
Set app = CreateObject("Outlook.Application")
Set Itm = app.CreateItem(0)
With Itm
.Subject = msgSubject
.To = Sendto
If Not IsMissing(CCto) Then .Cc = CCto
If Len(Trim(BCCto)) > 0 Then
.Bcc = BCCto
End If
.HTMLBody = msgBody
.BodyFormat = 2 '1=Plain text, 2=HTML 3=RichText -- ISSUE: this does not keep HTML formatting -- converts all text
'On Error Resume Next
If Len(Trim(fAttach)) > 0 Then .Attachments.Add (fAttach) ' Must be complete path'and filename if you require an attachment to be included
'Err.Clear
'On Error GoTo 0
.Save ' This property is used when you want to saves mail to the Concept folder
.Display ' This property is used when you want to display before sending
'.Send ' This property is used if you want to send without verification
End With
Set app = Nothing
Set Itm = Nothing
End Function
Here is the error I receive:
