Reputation: 256
Fixing this "Sent Email on Due Date" Script?
Although I know absolutely nothing of VBA, I've read about a dozen topics on the subject on multiple communities in an attempt to figure out something, a way to do it.
I found the script that was the most likely to work in my case, analyzed it, switched the references, cells and so on. I think I am getting close to something functional, alas, I fear it is as far as my knowledge and Trials & Errors goes.
The script currently does nothing... E5 to E35 contains the due dates, the cell next to each of these cells contain the "Sent" and "Not Sent" value so it doesn't send duplicate emails.
This is in the sheet that it needs to run:
Option Explicit
Private Sub Worksheet_Calculate()
Dim FormulaCell As Range
Dim FormulaRange As Range
Dim NotSentMsg As String
Dim MyMsg As String
Dim SentMsg As String
Dim MyLimit As Double
NotSentMsg = "Not Sent"
SentMsg = "Sent"
'Above the MyLimit value it will triger the email
MyLimit = Today()
Set FormulaRange = Me.Range("E5:E35")
On Error GoTo EndMacro:
For Each FormulaCell In FormulaRange.Cells
With FormulaCell
If IsNumeric(.Value) = False Then
MyMsg = "Not numeric"
Else
If .Value > MyLimit Then
MyMsg = NotSentMsg
If .Offset(0, 1).Value = NotSentMsg Then
strTO = "[email protected]"
strCC = ""
strBCC = ""
strSub = "Greetings, " & Cells(FormulaCell.Row, "B").Value
strBody = "Hi Sir " & vbNewLine & vbNewLine & _
"This email is to notify that you need to do your task : " & Cells(FormulaCell.Row, "B").Value & _
vbNewLine & vbNewLine & "Regards, Yourself"
If sendMail(strTO, strSub, strBody, strCC) = True Then MyMsg = SentMsg
' Call Mail_with_outlook2
End If
Else
MyMsg = NotSentMsg
End If
End If
Application.EnableEvents = False
.Offset(0, 1).Value = MyMsg
Application.EnableEvents = True
End With
Next FormulaCell
ExitMacro:
Exit Sub
EndMacro:
Application.EnableEvents = True
MsgBox "Some Error occurred." _
& vbLf & Err.Number _
& vbLf & Err.Description
End Sub
And this is the module I use to send the emails:
Option Explicit
Public FormulaCell As Range
Public strTO As String
Public strCC As String
Public strBCC As String
Public strSub As String
Public strBody As String
Public strAttach As String
Public Function sendMail(strTO As String, strSub As String, strBody As String, Optional strCC As String, Optional strBCC As String, Optional strAttach As String) As Boolean
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error GoTo errorMail
With OutMail
.To = strTO
If Len(Trim(strCC)) > 0 Then .CC = strCC
If Len(Trim(strBCC)) > 0 Then .BCC = strBCC
.Subject = strSub
.Body = strBody
If Len(Trim(strAttach)) > 0 Then
If Dir(strAttach, vbNormal) <> "" Then .Attachments.Add (strAttach)
End If
.Send
End With
sendMail = True
exitFunction:
Err.Clear
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
Exit Function
errorMail:
MsgBox "Some Error occurred." _
& vbLf & Err.Number _
& vbLf & Err.Description
GoTo exitFunction
End Function
Many thanks for any help given to this tremendous task!
Upvotes: 1
Views: 91
Answers (2)
Reputation: 256
Good news! The script below appears to work properly with my document. Although it only sends email for tasks that still have time left! I would need the script to send an email only when the date is the same as "Today()" How do I do that?
Pretty sure it is something to do with the "My Limit = Date" line, but how do I change Date to include only the current day?
Option Explicit
Private Sub Worksheet_Calculate()
Dim FormulaCell As Range
Dim FormulaRange As Range
Dim NotSentMsg As String
Dim MyMsg As String
Dim SentMsg As String
Dim MyLimit As Double
NotSentMsg = "Not Sent"
SentMsg = "Sent"
'Above the MyLimit value it will triger the email
MyLimit = Date
Set FormulaRange = Me.Range("E5:E35")
On Error GoTo EndMacro:
For Each FormulaCell In FormulaRange.Cells
With FormulaCell
If .Value > MyLimit Then
MyMsg = NotSentMsg
If .Offset(0, 1).Value = NotSentMsg Then
strTO = "[email protected]"
strCC = "[email protected]"
strBCC = ""
strSub = "Greetings " & Cells(FormulaCell.Row, "B").Value
strBody = "Hi Sir, " & vbNewLine & vbNewLine & _
"This email is to notify that you need to do your task : " & Cells(FormulaCell.Row, "B").Value & _
vbNewLine & vbNewLine & "Regards, Yourself"
If sendMail(strTO, strSub, strBody, strCC) = True Then MyMsg = SentMsg
' Call Mail_with_outlook2
End If
Else
MyMsg = NotSentMsg
End If
Application.EnableEvents = False
.Offset(0, 1).Value = MyMsg
Application.EnableEvents = True
End With
Next FormulaCell
ExitMacro:
Exit Sub
EndMacro:
Application.EnableEvents = True
MsgBox "Some Error occurred." _
& vbLf & Err.Number _
& vbLf & Err.Description
End Sub
Upvotes: 0
Reputation: 1290
Can you try the following code by debugging step by step? If there is an error, press debug and comment which line gets what kind of error. I would love to know if this gets you closer to your destination.
Private Sub Worksheet_Calculate()
Dim FormulaCell As Range
Dim FormulaRange As Range
Dim NotSentMsg As String
Dim MyMsg As String
Dim SentMsg As String
Dim MyLimit As Date
NotSentMsg = "Not Sent"
SentMsg = "Sent"
MyLimit = Date
Set FormulaRange = Me.Range("E5:E35")
'On Error GoTo EndMacro:
For Each FormulaCell In FormulaRange.Cells
With FormulaCell
If (IsDate(.Value) = True) Then
If (.Value > MyLimit) Then
If .Offset(0, 1).Value = NotSentMsg Then
strTO = "[email protected]"
strCC = ""
strBCC = ""
strSub = "Greetings, " & Cells(FormulaCell.Row, "B").Value
strBody = "Hi Sir " & vbNewLine & vbNewLine & _
"This email is to notify that you need to do your task : " & Cells(FormulaCell.Row, "B").Value & _
vbNewLine & vbNewLine & "Regards, Yourself"
Call sendMail(strTO, strSub, strBody, strCC)
MyMsg = SentMsg
End If
Else
MyMsg = NotSentMsg
End If
End If
Application.EnableEvents = False
.Offset(0, 1).Value = MyMsg
Application.EnableEvents = True
End With
Next FormulaCell
'EndMacro:
'Application.EnableEvents = True
'MsgBox "Some Error occurred." _
' & vbLf & Err.Number _
' & vbLf & Err.Description
End Sub
Upvotes: 2