I am trying to use the standard code to email a workbook to multiple recipients but build in some error handling that is likely to arise in my model.
If the email address is not available the cell where the email address would be found would read "Pending Search...".
If that is the case the loop simply needs to skip that cell and move on the the next email address.
Below is my code. The issue is coming from the IF/Then/Next line. I am getting a Next without For error. Any input would be greatly appreciated.
Sub Mail_workbook_Outlook_1()
Dim OutApp As Object
Dim OutMail As Object
Dim Position_In_Loop As Long
Dim Total_Emails As Long
Dim Email_Address As String
Dim Dashboard As Worksheet
Set Dashboard = ActiveWorkbook.Worksheets("Dashboard")
Dim Body As Range
Set Body = Dashboard.Range("F13")
Dim Attachment As Range
Set Attachment = Dashboard.Range("F24")
With Dashboard
Total_Emails = Dashboard.Range("G3")
End With
For Position_In_Loop = 1 To Total_Emails
Email_Address = Dashboard.Range("C3").Offset(Position_In_Loop, 0)
If Email_Address = "Pending Search..." Then Next Position_In_Loop
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "Email_Address"
.CC = ""
.BCC = ""
.Subject = "Open Job Violations"
.Body = "Body"
.Attachments.Add (Attachment)
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
Next Position_In_Loop
End Sub
You shouldn't increment the loop like that. You are going to skip emails. Wrap the whole the Outlook mail code in an If statement.
Option Explicit
Sub Mail_workbook_Outlook_1()
Dim OutApp As Object
Dim OutMail As Object
Dim Position_In_Loop As Long
Dim Total_Emails As Long
Dim Email_Address As String
Dim Dashboard As Worksheet
Set Dashboard = ActiveWorkbook.Worksheets("Dashboard")
Dim Body As Range
Set Body = Dashboard.Range("F13")
Dim Attachment As Range
Set Attachment = Dashboard.Range("F24")
With Dashboard
Total_Emails = Dashboard.Range("G3")
End With
For Position_In_Loop = 1 To Total_Emails
Email_Address = Dashboard.Range("C3").Offset(Position_In_Loop, 0)
If Email_Address <> "Pending Search..." Then
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "Email_Address"
.CC = ""
.BCC = ""
.Subject = "Open Job Violations"
.Body = "Body"
.Attachments.Add Attachment
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End If
Next Position_In_Loop
End Sub
change this line
If Email_Address = "Pending Search..." Then Next Position_In_Loop
to
If Email_Address = "Pending Search..." Then
Position_In_Loop=Position_In_Loop+1
end if
Related
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 using the already known Subroutine to send a warning email to outlook whenever a condition is met.
In the routine I define an string array under the name DatePassed in which I store some dynamical values and I intent to return it's content in the Subject of the email.
The problem is that I don't know how exactly to handle DatePassed so to return me the whole array not just the first element.
How would I do this?
Sub Mail_workbook_Outlook_1()
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
Dim DatePassed(100) As Variant
Dim i As Integer
For i = 6 To 13
If Cells(i, 1) < Date Then
DatePassed(i - 6) = Cells(i, 2)
End If
Next i
With OutMail
.To = "Joerge#Johnson.com"
.CC = "James#Johnson.com"
.BCC = ""
.Subject = "Unmanaged Clients"
.Body = DataPassed
.Attachments.Add ActiveWorkbook.FullName
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Try this.
I have just added a Loop to run through the Array and stored it as a string which then gets assigned to the .Body
Sub Mail_workbook_Outlook_1()
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
Dim DatePassed(100) As Variant
Dim i As Integer
For i = 6 To 13
If Cells(i, 1) < Date Then
DatePassed(i - 6) = Cells(i, 2)
End If
Next i
'=================================================
'New Section
Dim DataPassedElementReference As Long
Dim DataPassedString As String
DataPassedString = ""
'Using 100 as this is waht you used to define the array
For DataPassedElementReference = 1 To 100
DataPassedString = DataPassedString & DataPassed(DataPassedElementReference) & " "
Next DataPassedElementReference
'=================================================
With OutMail
.To = "Joerge#Johnson.com"
.CC = "James#Johnson.com"
.BCC = ""
.Subject = "Unmanaged Clients"
'Note the difference here
'.Body = DataPassed
.Body = DataPassedString
.Attachments.Add ActiveWorkbook.FullName
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
I am trying to achieve:
the email was sent to Outlook "Sent Items" folder therefore email is
not in the "Outbox" folder.
email did not return due to delivery failure (email will be in the
"Inbox" folder deliver by postmaster#mail.hotmail.com)
The following code is used to send an email from an Access form via Outlook:
Private Sub cmdEmail1_Click()
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim strBody As String
Dim strPDF As String
Dim strFolder As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(olMailItem)
strBody = Me.txtSubject
strPDF = Me.txtFile
On Error Resume Next
With OutMail
.To = Me.txtemail
.CC = ""
.BCC = Me.txtBBCemail
.Subject = Me.txtSubject
.Body = Me.txtMessage
.Recipients.ResolveAll
' .SendUsingAccount = OutApp.Session.Accounts.Item(2) '2nd email
.SentOnBehalfOfName = Me.txtFromEmail
.Attachments.Add strPDF 'attachments
.Send
End With
Me.txtSent = "email was sent to Outlook "
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Thanks a lot
Norbert
Both of these will be asynchronous and you will be able to process the notification at a later point, seconds or even minutes later.
I don't think #1 will help you much - it only tells you that the network was not disconnected. Why does it matter? Even if it is down, Outlook will send the message later.
For #2, it all depends on who sent the NDR. If it is Exchange, you will be able to figure out the bad recipient address. Otherwise you might just get a message with no good way to figure out what the problematic recipient was.
EDIT. For Items.ItemAdd, see the following (off the top of my head):
Dim OutApp As Outlook.Application
Dim WithEvents SentItems As Outlook.Items
sub SentItems_ItemAdd(Item As Object)
MsgBox Item.Subject
end sub
Private Sub cmdEmail1_Click()
Dim OutMail As Outlook.MailItem
Dim strBody As String
Dim strPDF As String
Dim strFolder As String
Dim ns As Outlook.Namespacee
if (OutApp Is Nothing) Then
Set OutApp = CreateObject("Outlook.Application")
set ns = OutApp.GetNamespace("MAPI")
ns.Logon
set SentItems = ns.GetDefaultFolder(olFolderSentMail).Items
End If
Set OutMail = OutApp.CreateItem(olMailItem)
strBody = Me.txtSubject
strPDF = Me.txtFile
On Error Resume Next
With OutMail
.To = Me.txtemail
.CC = ""
.BCC = Me.txtBBCemail
.Subject = Me.txtSubject
.Body = Me.txtMessage
.Recipients.ResolveAll
' .SendUsingAccount = OutApp.Session.Accounts.Item(2) '2nd email
.SentOnBehalfOfName = Me.txtFromEmail
.Attachments.Add strPDF 'attachments
.Send
End With
Me.txtSent = "email was sent to Outlook "
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
I tried the following code (I changed the real e-mail address), and it does work on the first cell in range, but after the first one, it gives me an error says: "run time error, the item has been moved or deleted", and then, it does not sending the others.... what should I need to fix in code ?
Sub sendMailWithLoop()
Dim missmatchCell As Range
Dim Missmatches_Rng As Range
Dim entityForRepeatedValues_Rng As Range
Dim OutMail As Object
Dim OutApp As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
If Range("D1000").End(xlUp).Value <> "Name" Then
Set Missmatches_Rng = Range(Range("D1000").End(xlUp), Range("D1000").End(xlUp).End(xlUp).Offset(1, 0))
Missmatches_Rng.Select
For Each missmatchCell In Selection
With OutMail
.To = "mymail#servername.com"
.Subject = "Attention !! missmatch found"
.Body = "The missmatch name is: " & missmatchCell.Offset(0, 1) & ", on: " & missmatchCell
.Send
End With
Next
End If
End Sub
thx !!
Move your Set OutMail = OutApp.CreateItem(0) inside the For as:
Sub sendMailWithLoop()
Dim missmatchCell As Range
Dim Missmatches_Rng As Range
Dim entityForRepeatedValues_Rng As Range
Dim OutMail As Object
Dim OutApp As Object
Set OutApp = CreateObject("Outlook.Application")
If Range("D1000").End(xlUp).Value <> "Name" Then
Set Missmatches_Rng = Range(Range("D1000").End(xlUp), Range("D1000").End(xlUp).End(xlUp).Offset(1, 0))
Missmatches_Rng.Select
For Each missmatchCell In Selection
Set OutMail = OutApp.CreateItem(olMailItem)
With OutMail
.To = "mymail#servername.com"
.Subject = "Attention !! missmatch found"
.Body = "The missmatch name is: " & missmatchCell.Offset(0, 1) & ", on: " & missmatchCell
.Send
End With
Next
End If
End Sub
I am trying to send emails from a specific account but it always sends from my main no matter how much code I try or what I do. Is there any way to tell it to send it from a particular account? I am writing my code in MS Access, but using Outlook objects.
Sub testEmail()
On Error Resume Next
Set outapp = GetObject(, "Outlook.Application")
If outapp Is Nothing Then
Set outapp = CreateObject("Outlook.Application")
End If
Set oMail = outapp.CreateItem(olMailItem)
With oMail
.To = "randomaddress#randomdomain.com"
.Subject = "test2"
.Send
End With
Set outapp = Nothing
Set oMail = Nothing
End Sub
Updated code:
Option Compare Database
Sub testEmail()
On Error Resume Next
Set oApp = CreateObject("Outlook.Application")
Set oMail = oApp.CreateItem(olMailItem)
Set olAccount = oApp.Account
Set olAccountTemp = oApp.Account
Dim foundAccount As Boolean
Dim strFrom As String
strFrom = "FROMADDY#randomaddress.com"
foundAccount = False
Set olAccounts = oApp.Application.Session.Accounts
For Each olAccountTemp In olAccounts
Debug.Print olAccountTemp.smtpAddress
If (olAccountTemp.smtpAddress = strFrom) Then
Set olAccount = olAccountTemp
foundAccount = True
Exit For
End If
Next
If foundAccount Then
Debug.Print "ACCT FOUND!"
With oMail
.To = "randomaddress#random.com"
.Body = "Message!"
.Subject = "test3"
.sendusingaccount = olAccount
End With
Else
Debug.Print "No acct found"
End If
Set oApp = Nothing
Set oMail = Nothing
Set olAccounts = Nothing
Set olAccount = Nothing
Set olAccountTemp = Nothing
End Sub
Try using
Set oMail.sendusingaccount=olAccount
instead of
oMail.sendusingaccount=olAccount
It worked for me, your code is perfect, just the Set is missing.
It is also much easier when the user can select the email address rather than account number. sendCaller loops through the accounts until it finds this email address. From there on it will call sendFile from where the message will be sent.
Sub sendCaller()
'creates outlook application
'chooses an email address and finds the corresponding account number
Dim OutApp As Object
Dim i As Integer, accNo As Integer
Set OutApp = CreateObject("Outlook.Application")
emailToSendTo = "name#domain.com" 'put required email address
'if smtp address=email we want to send to, acc no we are looking for is identified
For i = 1 To OutApp.Session.Accounts.Count
'Uncomment the Debug.Print command to see all email addresses that belongs to you
'''Debug.Print "Acc name: " & OutApp.Session.Accounts.Item(i) & " Acc number: " & i & " email: " & OutApp.Session.Accounts.Item(i).smtpAddress
If OutApp.Session.Accounts.Item(i).smtpAddress = emailToSendTo Then accNo = i
Next i
sendFile accNo
End Sub
Sub sendFile(accountNo As Integer)
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = "recipient#domain.com"
.Subject = "Test"
.Body = "Body"
Set .SendUsingAccount = OutApp.Session.Accounts.Item(accountNo)
.Send
End With
End Sub