How to stop sending emails multiply times when file is opened - excel

I need help with the code to send emails only once a day.
When the file is opened, the code is set to automatically send emails and is based on due date. However, this file can be opened multiple times throughout the course of the day. I need it to only send an email once a day (1st time the file is opened) but I can't figure how to correctly code it.
For i = 2 To lRow
If Cells(i, 8).Value <> "Completed" Then
If Cells(i, 2) <> "" Then
toDate = Replace(Cells(i, 5), ".", "/")
If Left(Cells(i, 18), 5) <> "Mail" And toDate - Date <= 7 Then
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
toList = Cells(i, 7)
eSubject = "ACTION ITEM - " & Cells(i, 3) & " is due on " & Cells(i, 5)
eBody = "NOTICE for " & Cells(i, 6) & vbCrLf & vbCrLf & "This is a reminder that you have task(s) that are due or ones that are past due. Please complete your tasks as soon as possible, then notify the Quality Administrator when the task is complete."
On Error Resume Next
With OutMail
.To = toList
.CC = ""
.BCC = ""
.Subject = eSubject
.Body = eBody
.bodyformat = 1
'.Display
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
Cells(i, 9) = "Mail Sent " & Date + Time
End If
End If
End If
Next i

Like this:
For i = 2 To lRow
If Cells(i, 8).Value <> "Completed" And _
Cells(i, 2) <> "" And _
Cells(i, 9) <> Date Then
'send the mail
Cells(i, 9) = Date '<<< store the date sent
End If
Next i

Related

Sending email working in Older version but not working in latest version of Excel

Every month I need to send hundred of emails to our suppliers and customers. For that I was using an Excel VBA to send multiple emails with multiple attachments from a list of email addresses and file names in an Excel table.
Excel VBA Source Link: https://github.com/sotirop/mergelook
But recently our IT team has updated our MS Excel from MS 2016 to MS 365 and OS to Windows 10.
Now I getting an error of -
'Run-time error '287': application-defined or object-defined error'
Gives error at line
.To = .To & "; " & ActiveSheet.Cells(row, col).Value
Type of VBA Error Screenshot
Line that gives an Error Screenshot
Please find the code that work on older version of excel but not in MS 365 and OS to Windows 10.
Any help to fix it would be greatly appreciated. Thank you so much in advance.
Sub sendEmailWithAttachments()
Dim OutLookApp As Object
Dim OutLookMailItem As Object
Dim myAttachments As Object
Dim row As Integer
Dim col As Integer
Set OutLookApp = CreateObject("Outlook.application")
row = 2
col = 1
ActiveSheet.Cells(row, col).Select
Do Until IsEmpty(ActiveCell)
workFile = Application.ActiveWorkbook.Path & "\" & "message.oft"
If FileExists(workFile) Then
Set OutLookMailItem = OutLookApp.CreateItemFromTemplate(workFile)
Else
MsgBox ("message.oft file does not exist in the folder!" & vbNewLine & _
"Also verify that the name is exactly 'message.oft'." & vbNewLine & _
"Exiting...")
Exit Sub
End If
Set myAttachments = OutLookMailItem.Attachments
'Do Until IsEmpty(ActiveCell)
Do Until IsEmpty(ActiveSheet.Cells(1, col))
With OutLookMailItem
If ActiveSheet.Cells(row, col).Value = "xxxFINISHxxx" Then
'MsgBox ("Exiting...")
Exit Sub
End If
If ActiveSheet.Cells(1, col).Value = "To" And Not IsEmpty(ActiveCell) Then
.To = .To & "; " & ActiveSheet.Cells(row, col).Value
ElseIf ActiveSheet.Cells(1, col).Value = "Cc" And Not IsEmpty(ActiveCell) Then
.CC = .CC & "; " & ActiveSheet.Cells(row, col).Value
ElseIf ActiveSheet.Cells(1, col).Value = "Bcc" And Not IsEmpty(ActiveCell) Then
.BCC = .BCC & "; " & ActiveSheet.Cells(row, col).Value
ElseIf ActiveSheet.Cells(1, col).Value = "Reply-To" And Not IsEmpty(ActiveCell) Then
.ReplyRecipients.Add ActiveSheet.Cells(row, col).Value
ElseIf ActiveSheet.Cells(1, col).Value = "attachment" And Not IsEmpty(ActiveCell) Then
attachmentName = ActiveSheet.Cells(row, col).Value
attachmentFile = Cells(ActiveCell.row, 17).Value & "\" & attachmentName
If FileExists(attachmentFile) Then
myAttachments.Add Cells(ActiveCell.row, 17).Value & "\" & ActiveSheet.Cells(row, col).Value
Else
MsgBox (Attachment & "'" & attachmentName & "'" & " file does not exist in the folder!" & vbNewLine & _
"Correct the situation and delete all messages from Outlook's Outbox folder before pressing 'Send Emails' again!" & vbNewLine & _
"Exiting...")
Exit Sub
End If
ElseIf ActiveSheet.Cells(1, col).Value = "xxxignorexxx" Then
' Do Nothing
Else
.Subject = Replace(.Subject, ActiveSheet.Cells(1, col).Value, ActiveSheet.Cells(row, col).Value)
'Write #1, .HTMLBody
.HTMLBody = Replace(.HTMLBody, ActiveSheet.Cells(1, col).Value, ActiveSheet.Cells(row, col).Value)
'ActiveSheet.Cells(10, 10) = .HTMLBody
End If
'MsgBox (.To)
End With
'Application.Wait (Now + #12:00:01 AM#)
col = col + 1
ActiveSheet.Cells(row, col).Select
Loop
OutLookMailItem.HTMLBody = Replace(OutLookMailItem.HTMLBody, "xxxNLxxx", "<br>")
OutLookMailItem.send
col = 1
row = row + 1
ActiveSheet.Cells(row, col).Select
Loop
End Sub
I'd recommend using the Recipients property of the MailItem class to set recipients and then calling the ResolveAll method which attempts to resolve all the Recipient objects in the Recipients collection against the Address Book. For example:
Set myRecipient = MyItem.Recipients.Add("Eugene Astafiev")
myRecipient.Resolve
If myRecipient .Resolved Then
myItem.Subject = "Test task"
myItem.Display
End If
See How To: Fill TO,CC and BCC fields in Outlook programmatically for more information.
Expanding on my comment above: it is a really bad idea to use To / CC / BCC properties as intermediary variables. Introduce dedicated variables and build them instead. Once you are out of the loop, set the To / CC / BCC properties without ever reading them.
vTo = "";
Do Until IsEmpty(ActiveSheet.Cells(1, col))
...
If ActiveSheet.Cells(1, col).Value = "To" And Not IsEmpty(ActiveCell)
Then
vTo = vTo & "; " & ActiveSheet.Cells(row, col).Value
...
Loop
OutLookMailItem.To = vTo

Auto restart a macro to run once per day

I need to send reminders 7 days before a certain deadline.
With help I managed to create this code:
Private Sub Workbook_Activate()
Dim i As Long
Dim OutApp, OutMail As Object
Dim strto, strcc, strbcc, strsub, strbody As String
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)
For i = 2 To Range("e65536").End(xlUp).Row
If Cells(i, 9) <> "Y" Then
If Cells(i, 5) - 7 < Date Then
strto = Cells(i, 7).Value 'email address
strsub = Cells(i, 1).Value & " " & Cells(i, 2).Value & " compleanno il " & Cells(i, 5).Value 'email subject
strbody = "Il compleanno di " & Cells(i, 1).Value & " " & Cells(i, 2).Value & " sarà il " & Cells(i, 5).Value & vbNewLine 'email body
With OutMail
.To = strto
.Subject = strsub
.Body = strbody
.Send
End With
Cells(i, 8) = "Mail Sent " & Now()
Cells(i, 9) = "Y"
End If
End If
Next
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
I have to start it manually every day because even if the deadline is updated the macro doesn't restart by itself.
I tried replacing Sub Workbook_Activate() with Sub Workbook_SelectionChange(ByVal Target As Range).

How to stop code from sending email when task is marked completed?

The following code works to send emails 7 days on or before the past due date but in order for it to run, it needs to be assigned to a button within Excel. When the file is opened, I want it to run the code automatically and send emails to those that have upcoming or overdue tasks. It needs to stop sending emails where tasks have been marked "Completed".
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
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With
Sheets(1).Select
lRow = Cells(Rows.Count, 5).End(xlUp).Row
Set OutApp = CreateObject("Outlook.Application")
For i = 2 To lRow
If Cells(i, 5) <> "" Then
toDate = Replace(Cells(i, 5), ".", "/")
If Left(Cells(i, 18), 5) <> "Mail" And toDate - Date <= 7 Then
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
toList = Cells(i, 7)
eSubject = "ACTION ITEM - " & Cells(i, 3) & " is due on " & Cells(i, 5)
eBody = "NOTICE for " & Cells(i, 6) & vbCrLf & vbCrLf & "You have task(s)coming due or ones that are past due. Please complete your tasks as soon as possible, then notify the Quality Administrator when the task is complete."
On Error Resume Next
With OutMail
.To = toList
.CC = ""
.BCC = ""
.Subject = eSubject
.Body = eBody
.bodyformat = 1
'.Display
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
Cells(i, 9) = "Mail Sent " & Date + Time
End If
End If
Next i
ActiveWorkbook.Save
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
End Sub
inside of your loop, put an if statement... fix the cell reference:
For i = 2 To lRow
If Cells(i,1).value <> "Completed" Then 'could also use Not Cells(i,1).value = "Completed"
'all of your regular code
End If
Next i
Edit1:
Update to use your code:
For i = 2 To lRow
If Cells(i,1).value <> "Completed" Then 'OPEN IT HERE
If Cells(i, 5) <> "" Then
toDate = Replace(Cells(i, 5), ".", "/")
If Left(Cells(i, 18), 5) <> "Mail" And toDate - Date <= 7 Then
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
toList = Cells(i, 7)
eSubject = "ACTION ITEM - " & Cells(i, 3) & " is due on " & Cells(i, 5)
eBody = "NOTICE for " & Cells(i, 6) & vbCrLf & vbCrLf & "You have task(s)coming due or ones that are past due. Please complete your tasks as soon as possible, then notify the Quality Administrator when the task is complete."
On Error Resume Next
With OutMail
.To = toList
.CC = ""
.BCC = ""
.Subject = eSubject
.Body = eBody
.bodyformat = 1
'.Display
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
Cells(i, 9) = "Mail Sent " & Date + Time
End If
End If
End If 'CLOSE IT HERE
Next i
A second way of doing it, with your existing If statement:
For i = 2 To lRow
If Cells(i, 5) <> "" Or Cells(i,1).value <> "Completed" Then
toDate = Replace(Cells(i, 5), ".", "/")
If Left(Cells(i, 18), 5) <> "Mail" And toDate - Date <= 7 Then
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
toList = Cells(i, 7)
eSubject = "ACTION ITEM - " & Cells(i, 3) & " is due on " & Cells(i, 5)
eBody = "NOTICE for " & Cells(i, 6) & vbCrLf & vbCrLf & "You have task(s)coming due or ones that are past due. Please complete your tasks as soon as possible, then notify the Quality Administrator when the task is complete."
On Error Resume Next
With OutMail
.To = toList
.CC = ""
.BCC = ""
.Subject = eSubject
.Body = eBody
.bodyformat = 1
'.Display
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
Cells(i, 9) = "Mail Sent " & Date + Time
End If
End If
Next i

How do i know if an email was sent and not closed while sending it through vba excel

I have a vba code which generates a outlook email, populates with required To, CC, Subject and Body when i change a particular column in excel. And when the email is sent my status column updates to 'Closed' and Email Sent Flag column updates to '1'.
But the problem is when i click on close instes on Send on my email( which was generated and auto populated) even then my status and Email sent flag column gets updated with Closed and 1 respectively. Below is my code.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim xOutApp As Object
Dim xMailItem As Object
Dim xMailBody As String
Dim html As String
Dim intR As String
Dim ccStr As String
Dim Signature As String
Dim html1 As String
'Dim itmevt As New CMailItemEvents
'Dim tsp As String
lRow = Cells(Rows.Count, 17).End(xlUp).Row
lRow1 = ThisWorkbook.Sheets("Validation Lists").Cells(Rows.Count, 4).End(xlUp).Row
html = "<br>" & ("Hi,") & ("Please spare some time to provide feedback for our service. This will help us to serve you better for upcoming services.") & "<br>"
For i = 2 To lRow1
ccStr = ";" & ThisWorkbook.Sheets("Validation Lists").Cells(i, "D").Value & ccStr
Next i
For i = 1 To lRow
If (Cells(i, "Q").Value = "Closed") And (Cells(i, "R").Value <> "1") Then
intR = MsgBox("Do you want to send a feedback for " & Cells(i, "B") & "Viz." & Cells(i, "C").Value & " to " & Cells(i, "C") & "?", vbQuestion + vbYesNo)
If intR = vbYes Then
Set xOutApp = CreateObject("Outlook.Application")
Set xMailItem = xOutApp.CreateItem(0)
With xMailItem
.To = Cells(i, "I").Value
.CC = ccStr
.display
Signature = .HTMLBody
.Subject = "Feedback for " & Cells(i, "B").Value & " viz. " & Cells(i, "C").Value
.HTMLBody = html & "This request was assited by " & Cells(i, "K").Value & "<br><br>" & Signature
'.dispaly
'.Send
End With
Cells(i, "R").Value = "1"
Set xRgSel = Nothing
Set xOutApp = Nothing
Set xMailItem = Nothing
On Error Resume Next
End If
If intR = vbNo Then Cells(i, "Q").Value = "In Progress"
End If
Next i
End Sub
You have to check if the message has been sent.
There exists a boolean message property named Sent.
Untested but could work:
Loop until .Sent is True.
With xMailItem
.To = Cells(i, "I").Value
.CC = ccStr
.display
Signature = .HTMLBody
.Subject = "Feedback for " & Cells(i, "B").Value & " viz. " & Cells(i, "C").Value
.HTMLBody = html & "This request was assited by " & Cells(i, "K").Value & "<br><br>" & Signature
Do Until .Sent = True
DoEvents
Loop
End With

Display error message and resume loop

I have created a VBA Macro code to generate emails with different recipients, subjects, mail content, attachments etc using various criterion...
The code works fine, EXCEPT when there is an issue with the attachments. When the macro fails to find a relevant file at the given location, it gives a popup message BUT DOES NOT progress the loop further.
My questions is, if anyone could please see where should the "Next" and "Exit Sub" be placed so as to keep on looping and generating "Error Popups" together with the "Email drafts" without stopping the code.
Thanks in advance...
Please find the code below...
Sub Email_Creation_Tool()
On Error GoTo ErrMsg
Dim wbk As Workbook
Dim OutApp As Object
Dim OutMail As Object, signature As String
Dim i As Range, j As Long
Dim objItem As Object
With ActiveSheet
Set i = Range("A2", Range("A2").End(xlDown))
For j = 1 To i.Rows.Count
Set OutApp = CreateObject("Outlook.Application")
If Cells(j + 1, 1).Value <> "" Then
Mailto = Cells(j + 1, 3).Value
If Mailto = "Sentence No. 1" Then
Mailto = "Friend1#abc.com"
MailSubject = Cells(j + 1, 1).Value & " Sentence No. 1"
MailBody = " Hi blah blah "
End If
If Mailto = "Sentence No. 2” Then
Mailto = "Friend2#abc.com; Friend3#abc.com"
CCTo = "CommonFriend#abc.com"
MailSubject = Cells(j + 1, 1).Value & " Sentence No. 2"
MailBody = "Hi blah blah,"
End If
If Mailto = "Sentence No. 2” Then
MailSubject = Cells(j + 1, 1).Value & " Sentence No. 3"
Mailto = "Friend2#abc.com; Friend3#abc.com"
CCTo = "CommonFriend#abc.com"
MailBody = " Hi blah blah "
End If
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(o)
With OutMail
.Display
signature = OutMail.body
With OutMail
.Subject = MailSubject
.To = Mailto
.CC = CCTo
.body = MailBody & vbNewLine & signature
Name "D:\Users\MY_PC\Desktop\" & Cells(j + 1, 1).Value & ".txt" As "D:\Users\MY_PC\Desktop\" & Cells(j + 1, 1).Value & "_trial.txt"
Attach = "D:\Users\MY_PC\Desktop\" & Cells(j + 1, 1).Value & "_trial.txt"
.Attachments.Add (Attach)
Exit Sub 'where should this be placed
On Error Resume Next 'where should this be placed
End With
Set OutMail = Nothing
Set OutApp = Nothing
End With
End If
On Error Resume Next 'where should this be placed
ErrMsg:
MsgBox ("Attachment WP" & (Cells(j + 1, 1).Value) & vbNewLine & _
"Not Found/Name Incorrect")
Next j
End With
End Sub
I edited your code "slightly", give it a try :
EDIT
What I changed is, I used "Select case" instead of multiple "Ifs", as you have multiple If's options. Then I added ".Save" and ".Close olpromptforsave" to save and close message window, in case it has attachment or no. Goto is good for jumping through code, like in this case.
So logic is:
if you don't find file to attach, skip to error message, then continues with nextJ code: save and close, proceed to another "j" (nextJ code runs no matter if file is found or not)
If you find file to attach, attach it, save, close, skip error message and continue to another "j"
Sub Email_Creation_Tool()
Dim wbk As Workbook
Dim OutApp As Object, OutMail As Object, objItem As Object
Dim i As Integer, j As Long, signature As String
For j = 2 To Range("A" & Rows.Count).End(xlUp).Row
If Cells(j + 1, 1).Value <> vbNullString Then
Mailto = Cells(j + 1, 3).Value
select case Mailto
case "Sentence No. 1"
Mailto = "Friend1#abc.com"
MailSubject = Cells(j + 1, 1).Value & " Sentence No. 1"
MailBody = " Hi blah blah "
case "Sentence No. 2"
Mailto = "Friend2#abc.com; Friend3#abc.com"
CCTo = "CommonFriend#abc.com"
MailSubject = Cells(j + 1, 1).Value & " Sentence No. 2"
MailBody = "Hi blah blah,"
case "Sentence No. 3"
MailSubject = Cells(j + 1, 1).Value & " Sentence No. 3"
Mailto = "Friend2#abc.com; Friend3#abc.com"
CCTo = "CommonFriend#abc.com"
MailBody = " Hi blah blah "
End Select
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.Display
signature = OutMail.body
.Subject = MailSubject
.To = Mailto
.CC = CCTo
.body = MailBody & vbNewLine & signature
Attach = "D:\Users\MY_PC\Desktop\" & Cells(j + 1, 1).Value & "_trial.txt"
If Dir(Attach) = vbNullString then GoTo ErrMsg
.Attachments.Add (Attach)
GoTo nextJ
ErrMsg:
MsgBox ("Attachment WP " & (Cells(j + 1, 1).Value) & vbNewLine & "Not Found/Name Incorrect")
nextJ:
.Save
.Close olpromptforsave
End With
End If
Next j
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Try using Go to statement Please look into this link

Resources