Sub SendReminderMail()
Dim OutlookApp As Object
Dim OutLookMailItem As Object
Dim iCounter As Integer
Dim MailDest As String
Set OutlookApp = CreateObject("Outlook.application")
Set OutLookMailItem = OutlookApp.CreateItem(0)
With OutLookMailItem
MailDest = ""
For iCounter = 1 To WorksheetFunction.CountA(Columns(34))
If MailDest = "" And Cells(iCounter, 34).Offset(0, -1) = "Send Reminder" Then
MailDest = Cells(iCounter, 34).Value
ElseIf MailDest <> "" And Cells(iCounter, 34).Offset(0, -1) = "Send Reminder" Then
MailDest = MailDest & ";" & Cells(iCounter, 34).Value
End If
Next iCounter
.BCC = MailDest
.Subject = "ECR Notification"
.HTMLBody = "Reminder: This is a test for an automatic ECR email notification. Please complete your tasks for ECR#"
.Send
End With
Set OutLookMailItem = Nothing
Set OutlookApp = Nothing
End Sub
Need code to email the values in columns AE with the "set reminder" text
GD mjac,
You are still shy with your information...?
Your presented code collects all addresses and subsequently sends a single message ? I would expect, based on your example sheet/data that you would want to send an email to each recipient for each ECR code that is 'open' ?
So assuming the following:
You want to send an email for every line where the "Send reminder" is
true
The email addresses in columns "AH" will differ for every line ?
In your code you use the Outlook.Application objects Set OutlookApp = CreateObject("Outlook.application"), be careful with opening application type objects and be sure to ensure they will be closed in the event the code finishes or when an error is triggered, otherwise you could potentially end up with a number of Outlook instances that are 'running' using valuable reqources. The below code has some basic error handling to ensure the OutlookApp object is closed if no longer required.
Setup your Workbook as follows:
In VB Editor under Tools|References find 'Microsoft Outlook xx.x Object Library', where xx.x represents the version of Outlook that you are working with. (see also: https://msdn.microsoft.com/en-us/library/office/ff865816.aspx) This will make for easier coding as you get intellisense suggestions for your objects.
Declare OutlookApp as public, above all other subs/functions etc. etc.
(i.e. at the top of your 'coding' window)
Public OutlookApp As Outlook.Application
your sendReminderMail() sub
Sub SendReminderMail()
Dim iCounter As Integer
Dim MailDest As String
Dim ecr As Long
On Error GoTo doOutlookErr:
Set OutlookApp = New Outlook.Application
For iCounter = 1 To WorksheetFunction.CountA(Columns(34))
MailDest = Cells(iCounter, 34).Value
ecr = Cells(iCounter, 34).Offset(0, -3).Value
If Not MailDest = vbNullString And Cells(iCounter, 34).Offset(0, -1) = "Send Reminder" Then
sendMail MailDest, ecr
MailDest = vbNullString
End If
Next iCounter
'basic errorhandling to prevent Outlook instances to remain open in case of an error.
doOutlookErrExit:
If Not OutlookApp Is Nothing Then
OutlookApp.Quit
End If
Exit Sub
doOutlookErr:
MsgBox Err.Description, vbOKOnly, Err.Source & ":" & Err.Number
Resume doOutlookErrExit
End Sub
added sendMail Function:
Function sendMail(sendAddress As String, ecr As Long) As Boolean
'Initiate function return value
sendMail = False
On Error GoTo doEmailErr:
'Initiate variables
Dim OutLookMailItem As Outlook.MailItem
Dim htmlBody As String
'Create the mail item
Set OutLookMailItem = OutlookApp.CreateItem(olMailItem)
'Create the concatenated body of the mail
htmlBody = "<html><body>Reminder: This is a test for an automatic ECR email notification.<br>" & _
"Please complete your tasks for ECR#" & CStr(ecr) & "</body></html>"
'Chuck 'm together and send
With OutLookMailItem
.BCC = sendAddress
.Subject = "ECR Notification"
.HTMLBody = htmlBody
.Send
End With
sendMail = True
doEmailErrExit:
Exit Function
doEmailErr:
MsgBox Err.Description, vbOKOnly, Err.Source & ":" & Err.Number
Resume doEmailErrExit
End Function
Related
I have a simple code to open Microsoft Outlook and send an email with an attachment. I would like to send the email securely. Meaning, I would like to know if there is any code that would be tantamount to pressing the "Send Securely" button in outlook. Here is my code so far.....
Sub EmailInvoice()
Dim OutlookApp As Object, OutlookMessage As Object
Dim FileName As String, EmailAddress As String
EmailAddress = Range("ProviderEmail").Value
FileName = "C:\Users\rblahblahblah.txt"
Set OutlookApp = GetObject(class:="Outlook.Application") 'Handles if
Outlook is already open
Err.Clear
If OutlookApp Is Nothing Then Set OutlookApp =
CreateObject(class:="Outlook.Application") 'If not, open Outlook
If Err.Number = 429 Then
MsgBox "Outlook could not be found, aborting.", 16, "Outlook Not Found"
Exit Sub
End If
'Create a new email message
Set OutlookMessage = OutlookApp.CreateItem(0)
'Create Outlook email with attachment
With OutlookMessage
.To = EmailAddress
.CC = ""
.BCC = ""
.Subject = "Invoice for Upload - " & Month
.Body = "Please upload the attached file to the Vendor Portal."
.Attachments.Add FileName
.Display
.Send
End With
End Sub
The code below will send it with a sensitivity enumeration but not securely (Certified Mail). I also add my signature (Default) to the email.
Sub Mail_workbook_Outlook_1()
'Working in Excel 2000-2013
'This example send the last saved version of the Activeworkbook
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim SigString As String
Dim Signature As String
For Each cell In ThisWorkbook.Sheets("Email List").Range("B1:B100")
If cell.Value Like "?*#?*.?*" And LCase(cell.Offset(0, 1).Value) = "yes" Then
strto = strto & cell.Value & ";"
End If
Next cell
If Len(strto) > 0 Then strto = Left(strto, Len(strto) - 1)
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
'Change only Mysig.htm to the name of your signature
SigString = Environ("appdata") & "\Microsoft\Signatures\Default.htm"
If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
Else
Signature = ""
End If
On Error Resume Next
With OutMail
.to = strto
.CC = ""
.BCC = ""
.Subject = ("*Confidential*: Policyholder Name Here - Policy # Here - Premium Bill")
.HTMLBody = "Attached is the most recent premium bill in Excel." & "<br><br>" & Signature
.Attachments.Add ActiveWorkbook.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Importance = 2 '(0=Low, 1=Normal, 2=High)
.Sensitivity = 3 '(0=Normal, 1=Personal, 2=Private, 3=Confidential)
.Send 'or use .Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Function GetBoiler(ByVal sFile As String) As String
'Dick Kusleika
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.readall
ts.Close
End Function
I have a code:
Sub sendEmail()
Dim OutlookApp As Object
Dim OutlookItem As Object
Dim i As Integer
Dim Address As String
Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookItem = OutlookApp.CreateItem(0)
With OutlookItem
For i = 4 To 15
If Cells(i, 18) <= Cells(i, 6) Then
Address = Cells(i, 14).Value
Set OutlookApp = CreateObject("Outlook.application")
Set OutlookItem = OutlookApp.CreateItem(0)
.To = Address
.Subject = "Calibration Due Soon !!!"
.Body = "Reminder: Calibration of " & Cells(i, 4) & "is due on " & Cells(i, 9)
.Send
Set OutlookItem = Nothing
Set OutlookApp = Nothing
'Application.Wait (Now + #12:00:08 AM#)
ElseIf Cells(i, 18) > Cells(i, 15) Then
Exit Sub
ElseIf Cells(i, 18) = "" And Cells(i, 15) = "" Then
Exit Sub
End If
Next i
End With
End Sub
It does send only first email then it prompts me with run-time error saying :
The item has been moved or deleted
And debugger highlights the " .To = Address" line.
When I use .Display instead of send it works.
Any ideas?
Re-creating the Outlook application object in every loop iteration does not make sense. It's equivalent to killing Outlook and re-starting it for every mail you send. Let's not do that.
First, set a reference to the "Microsoft Outlook 15.0 Object Library" in your Excel VBA project (or whatever version you happen to have installed).
Now you can create an Outlook object directly with New and it also enables the autocompletion and all the Outlook-specific constants, like olMailItem.
Now your code can be condensed to something like this:
Sub sendEmail()
Dim OutlookApp As New Outlook.Application
Dim r As Range
For Each r In ActiveSheet.Range("4:15").Rows
If r.Cells(18) <= r.Cells(6) And r.Cells(18) > "" And r.Cells(15) > "" Then
With OutlookApp.CreateItem(olMailItem)
.To = r.Cells(14)
.Subject = "Calibration Due Soon !!!"
.Body = "Reminder: Calibration of " & r.Cells(4) & " is due on " & r.Cells(9)
.Send
End With
End If
Next r
OutlookApp.Quit
Set OutlookApp = Nothing
End Sub
Looking for help with sending emails to a list of people. My code has a simple loop and grabs the value each time through of where to send the email. While testing, the first email will always get sent. After that, the 2nd time through I get error on ".To"
Run-time error - '-2147221238 (8004010a):
The item has been moved or deleted.
This is puzzling to me because the code does accurately grab the next email value?
The emails need to be sent one by one, instead of adding the recipients to a list of bcc. Is this possible with VBA? Thanks in advance!
Sub TestingAgain()
'Setting up the Excel variables.
Dim outApp As Object
Dim outMailItem As Object
Dim iCounter As Integer
Dim sDest As String
Dim sName As String
'Create the Outlook application and the empty email.
Set outApp = CreateObject("Outlook.Application")
Set outMailItem = outApp.CreateItem(0)
With outMailItem
sDest = ""
For i = 2 To WorksheetFunction.CountA(Columns(1))
If i <> "" Then
'Grab first name and email
sDest = Cells(i, 5).Value
sName = Cells(i, 1).Value
'Send each email
.To = sDest
.Subject = "FYI"
.htmlbody = "Some stuff"
.Send
Else
MsgBox ("Error")
End If
Next i
End With
'Clean up the Outlook application.
Set outMailItem = Nothing
Set outApp = Nothing
End Sub
When you send the e-mail, the mailItem instance is done and not available anymore. Refactor your code like :
Sub TestingAgain()
'Setting up the Excel variables.
Dim outApp As Object
Dim outMailItem As Object
Dim iCounter As Integer
Dim sDest As String
Dim sName As String
'Create the Outlook application and the empty email.
Set outApp = CreateObject("Outlook.Application")
sDest = ""
For i = 2 To WorksheetFunction.CountA(Columns(1))
If i <> "" Then
'/ Create the mail item instance.
Set outMailItem = outApp.CreateItem(0)
With outMailItem
'Grab first name and email
sDest = Cells(i, 5).Value
sName = Cells(i, 1).Value
'Send each email
.To = sDest
.Subject = "FYI"
.htmlbody = "Some stuff"
.send
'/ Once sent, mail item is no more available.
End With
Else
MsgBox ("Error")
End If
Next
'Clean up the Outlook application.
Set outMailItem = Nothing
Set outApp = Nothing
End Sub
I am an absolute beginner and try to facilitate a few tasks in my colleagues daily work. I want to create a code that sends reminder mails with information from an excel file. The idea is that Excel should check every relevant row from row 12 on and check if there is an "x" written in a column that marks for which row I would like to send a reminder.
With the code below I can generate all the emails, but I have difficulties where and how to include the check for if ('If Cells(s, 6).Value = "x" Then') so that that Excel continues through all the rows that are filled out.
Many thanks for your help!
Sub SendReminderMail()
Dim s As Long
Dim OutLookApp As Object
Dim OutLookMailItem As Object
Dim iCounter As Integer
Dim MailDest As String
If MsgBox("Are you sure?", vbYesNo) = vbNo Then Exit Sub
Set OutLookApp = CreateObject("Outlook.application")
Set OutLookMailItem = OutLookApp.CreateItem(0)
s = 12
Do Until Trim$(Cells(s, 1).Value) = ""
Set OutLookMailItem = OutLookApp.CreateItem(0)
With OutLookMailItem
.To = Cells(s, 5).Value
.Subject = "Reminder: " & Cells(1, 7).Value
.Body = "Text, " & vbCrLf & vbCrLf & "Text'" & Cells(s, 2).Value
s = s + 1
.Display
End With
Loop
End Sub
Since you are checking every row with the Do...Loop then you need to check the if inside that loop. I've moved the increment to s outside the If so that it happens whether or not you create a mail item. Otherwise you'd only change rows if there was a mail item to send, and that means you'd be stuck looping on a row where there was no "x".
Sub SendReminderMail()
Dim s As Long
Dim OutLookApp As Object
Dim OutLookMailItem As Object
Dim iCounter As Integer
Dim MailDest As String
If MsgBox("Are you sure?", vbYesNo) = vbNo Then Exit Sub
Set OutLookApp = CreateObject("Outlook.application")
Set OutLookMailItem = OutLookApp.CreateItem(0)
s = 12
Do Until Trim$(Cells(s, 1).Value) = ""
If Cells(s,6).Value = "x" Then
Set OutLookMailItem = OutLookApp.CreateItem(0)
With OutLookMailItem
.To = Cells(s, 5).Value
.Subject = "Reminder: " & Cells(1, 7).Value
.Body = "Text, " & vbCrLf & vbCrLf & "Text'" & Cells(s, 2).Value
.Display
End With
End If
s = s + 1
Loop
End Sub
I am using the following code to loop through each row in the spreadsheet. whenever it meets the if condition, the reminder email will be automatically sent. But in this way, only one same email will be sent with all email address show in "To:". For privacy purpose,
I want the email to be sent to different receiver individually (send the email to one receiver a time). How should I update the loop to do this? Any thoughts?
Sub SendReminderMail()
Dim OutLookApp As Object
Dim OutLookMailItem As Object
Dim iCounter As Integer
Dim MailDest As String
Dim NumRows As Integer
Set OutLookApp = CreateObject("Outlook.Application")
Set OutLookMailItem = OutLookApp.CreateItem(0)
NumRows = ActiveSheet.UsedRange.Rows.Count
With OutLookMailItem
MailDest = ""
For iCounter = 1 To NumRows
If MailDest = "" And Cells(iCounter, 6).Offset(0, -2) = "Send Reminder" Then
MailDest = Cells(iCounter, 6).Value
ElseIf MailDest <> "" And Cells(iCounter, 6).Offset(0, -2) = "Send Reminder" Then
MailDest = MailDest & ";" & Cells(iCounter, 6).Value
End If
Next iCounter
.To = MailDest
.CC = CC
.BCC = BCC
.Subject = "FYI"
.Body = "Reminder: Some Message"
.Send
End With
Set OutLookMailItem = Nothing
Set OutLookApp = Nothing
End Sub
You just need to move the part of the code the creates and sends the email into the loop.
Sub SendReminderMail()
Dim OutLookApp As Object
Dim OutLookMailItem As Object
Dim iCounter As Integer
Dim MailDest As String
Dim NumRows As Integer
Set OutLookApp = CreateObject("Outlook.Application")
Set OutLookMailItem = OutLookApp.CreateItem(0)
NumRows = ActiveSheet.UsedRange.Rows.Count
For iCounter = 1 To NumRows
MailDest = ""
If Cells(iCounter, 6).Offset(0, -2) = "Send Reminder" Then
Set OutLookMailItem = OutLookApp.CreateItem(0)
With OutLookMailItem
MailDest = Cells(iCounter, 6).Value
.To = MailDest
.CC = CC
.BCC = BCC
.Subject = "FYI"
.Body = "Reminder: Some Message"
.Send
Set OutLookMailItem = Nothing
End With
End If
Next iCounter
Set OutLookApp = Nothing
End Sub