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
Related
If there is no attachment file is present at path mail should not send.
Is there any possibility that mail should not be send if there is no attachment?
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = " Hello"
On Error Resume Next
With OutMail
.to = "test#gmail.com"
.cc = "test1#gmail.com"
.BCC = ""
.Subject = "TRANSACTING : " & Format(Date, "DD-MMM-YYYY")
.HTMLBody = strbody
'You can add an attachment like this
.Attachments.Add ("E:\Auto Reports\test.xlsb")
.send 'or use .Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
First of all using On Error Resume Next in the way you did just mute any errors. But the errors still occur they just don't show. Using On Error Resume Next is a very bad practice and you should avoid that unless you really know why you need to do it.
Instead you should always implement a proper error handling like below.
Now the error is shown if adding an attachment to the email fails and the email is not sent.
Option Explicit
Public Sub SendMyEMail()
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = " Hello"
On Error GoTo MAIL_ERROR 'jump to the error handler if an error occurs
With OutMail
.to = "test#gmail.com"
.cc = "test1#gmail.com"
.BCC = ""
.Subject = "TRANSACTING : " & Format(Date, "DD-MMM-YYYY")
.HTMLBody = strbody
'You can add an attachment like this
.Attachments.Add ("C:\Auto Reports\test.xlsb")
.send 'or use .Display
End With
On Error GoTo 0 'stop error handling here (no jumps to the error handler anymore.
'The following 2 lines can be omitted because it is done automatically on exit sub
'So these are completely unnecessary.
'Set OutMail = Nothing
'Set OutApp = Nothing
Exit Sub 'we need this to not to run into error handler if everything was ok
MAIL_ERROR: 'Show error message
MsgBox "An error occured during sending the email. The email was not sent: " & vbNewLine & Err.Description, vbCritical, "Error " & Err.Number, Err.HelpFile, Err.HelpContext
End Sub
Send multiple different e-mails
To send multiple different e-mails you need to make your procedure a more universal function receiving some parameters.
Public Function SendMyEMail(MailTo As String, MailCC As String, MailSubject As String, MailFileName As String)
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = " Hello"
On Error GoTo MAIL_ERROR 'jump to the error handler if an error occurs
With OutMail
.To = MailTo
.CC = MailCC
.BCC = ""
.Subject = MailSubject
.HTMLBody = strbody
'You can add an attachment like this
.Attachments.Add MailFileName
.send 'or use .Display
End With
On Error GoTo 0 'stop error handling here (no jumps to the error handler anymore.
'The following 2 lines can be omitted because it is done automatically on exit sub
'So these are completely unnecessary.
'Set OutMail = Nothing
'Set OutApp = Nothing
Exit Function 'we need this to not to run into error handler if everything was ok
MAIL_ERROR: 'Show error message
MsgBox "An error occured during sending the email. The email was not sent: " & vbNewLine & Err.Description, vbCritical, "Error " & Err.Number, Err.HelpFile, Err.HelpContext
End Function
And a procedure SendMultipleEmails looping through a worksheet and run SendMyEMail for every row.
Public Sub SendMultipleEmails()
Dim wsMail As Worksheet
Set wsMail = Worksheets("MyMailSheet")
Dim iRow As Long, lRow As Long
lRow = wsMail.Cells(wsMail.Rows.Count, "A").End(xlUp).Row 'find last used row in column A
For iRow = 1 To lRow 'run from first to last used row
SendMyEMail wsMail.Cells(i, "A"), wsMail.Cells(i, "B"), wsMail.Cells(i, "C"), wsMail.Cells(i, "D")
'SendMyEMail for every row in that sheet where MailTo is in column A, MailCC is in column B, …
Next iRow
End Sub
You can check if the file exists before attempting to draft the email.
Sub SendEmail()
'Exit if file does not exist
If Len(Dir("E:\Auto Reports\test.xlsb", vbDirectory)) = 0 Then Exit Sub
'Proceed
Dim OutApp As Object
'rest of code
End Sub
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
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 can send a single Outlook message using Excel VBA. However, I want to loop through my rows and send an email for each row that meets a certain condition.
Unfortunately, when I put the email code in a for loop only one email gets sent or none at all (depending on how I structure the code).
Is there something about calling Outlook multiple times that I should know?
Private Sub CommandButton1_Click()
Dim OutApp As Object
Dim OutMail As Object
Dim myValue As Variant
Dim contactRange As Range
Dim cell As Range
Dim toAddy As String, nextAddy As String
Dim i As Integer
Set contactRange = Me.Range("ContactYesNo")
myValue = InputBox("Enter body of email message.")
For Each cell In contactRange
If Range(Cells(cell.Row, cell.Column).Address).Value = "Yes" Then
nextAddy = Range(Cells(cell.Row, cell.Column).Address).Offset(0, 5).Value
toAddy = nextAddy & ", " & toAddy
End If
Next cell
If Len(toAddy) > 0 Then
toAddy = Left(toAddy, Len(toAddy) - 2)
End If
For i = 0 To 1 'short loop for testing purposes
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = toAddy
.CC = ""
.BCC = ""
.Subject = "test email"
.Body = myValue
.Send
End With
Set OutMail = Nothing
Set OutApp = Nothing
Next i
End Sub
Take the CreateObject line out of the loop:
Set OutApp = CreateObject("Outlook.Application")
For i = 0 To 1 'short loop for testing purposes
Set OutMail = OutApp.CreateItem(0)
...
I've tried to clean up your logic stream but there are many unanswered questions due to the lack of sample data, explicit error messages and output.
Private Sub CommandButton1_Click()
Dim outApp As Object
Dim outMail As Object
Dim myValue As Variant
Dim contactRange As Range
Dim cell As Range
Dim toAddy As String, nextAddy As String
Dim i As Integer
Set outApp = CreateObject("Outlook.Application")
Set contactRange = Me.Range("ContactYesNo")
myValue = InputBox("Enter body of email message.")
With Worksheets(contactRange.Parent.Name) '<~~ surely you know what worksheet you are on..!?!
For Each cell In contactRange
If cell.Value = "Yes" Then 'no need to define a range by the range's address
nextAddy = cell.Offset(0, 5).Value 'again, no need to define a range by the range's address
toAddy = nextAddy & ";" & toAddy 'use a semi-colon to concatenate email addresses
End If
Next cell
End With
If Len(toAddy) > 0 Then
toAddy = Left(toAddy, Len(toAddy) - 2) 'I have no idea why you need to shorten the toAddy by 2
'only send mail where one or more addresses exist
For i = 0 To 1 'short loop for testing purposes
Set outMail = outApp.CreateItem(0)
With outMail
.To = toAddy
.CC = ""
.BCC = ""
.Subject = "test email"
.Body = myValue
.Send
End With
Set outMail = Nothing
Next i
End If
Set outApp = Nothing
End Sub
OK, so I re-wrote the code based on the feedback. I used a loop to send emails one at a time instead of concatenating the addresses together as I wanted to personalize each email. I also needed to create a form to handle the input as inputbox only accepts 256 characters.
A form was pretty much required as I needed to capture the subject line, message body, salutation, path the to the attachment etc.:
Private Sub CommandButton1_Click()
Dim subject As String, msg As String, path As String
subject = TextBox1.Value
msg = TextBox2.Value & vbCrLf & vbCrLf & "Sincerely," & vbCrLf & TextBox4.Value & vbCrLf & TextBox5
path = TextBox3.Value
UserForm1.Hide
Module1.sendEmail subject, msg, path
End Sub
I placed the email code in Module1. Note, be sure to set the .sentOnBehalfOfName attribute or Outlook will simply pick an account which may not be the one you want if you have multiple accounts registered:
Public Sub sendEmail(subject As String, msg As String, path As String)
Dim outApp As Object
Dim outMail As Object
Dim contactRange As Range, cell As Range
Dim toAddy As String, emailMsg As String
Dim count As Integer
Set outApp = CreateObject("Outlook.Application")
Set contactRange = Range("ContactYesNo")
With Worksheets("IT consulting")
For Each cell In contactRange
If cell.Value = "Yes" Then
count = count + 1
toAddy = cell.Offset(0, 6).Value
emailMsg = "Dear " & cell.Offset(0, 2).Value & "," & vbCrLf & vbCrLf & msg
Set outMail = outApp.CreateItem(0)
With outMail
.SentOnBehalfOfName = "me#someemail.com"
.To = toAddy
.CC = ""
.BCC = ""
.subject = subject
.Body = emailMsg
.Attachments.Add path
'.Display
.Send
End With
'log the action
cell.Offset(0, 1).Value = Now & vbCrLf & cell.Offset(0, 1).Value
End If
Set outMail = Nothing
Next cell
End With
Set outApp = Nothing
MsgBox "total emails sent: " & count
End Sub
I have code to send email. I'm struggling to CC the sender? If I mail I should get the CC, if my colleague mails he should get the CC.
Our usernames aren't firstname.lastname but our email addresses are.
Sub SendPDF()
Dim strPath As String, strFName As String
Dim OutApp As Object, OutMail As Object
Title = Format(Now(), "dd/mm/yyyy") & " - " & ActiveSheet.Name & ""
strPath = Environ$("temp") & "\" 'Or any other path, but include trailing "\"
strFName = ActiveWorkbook.Name
strFName = Format(Now(), "yyyymmdd") & " - " & ActiveSheet.Name & ".pdf"
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
strPath & strFName, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "firstname.surname#email.com"
.CC = ""
.BCC = ""
.Subject = Title
.body = "Please see attached"
.Attachments.Add strPath & strFName
'.Display
.Send
End With
Kill strPath & strFName
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
You can use the CurrentUser property of the Namespace class to get the currently logged-on user as a Recipient object. Then you can get the Address property value which representing the e-mail address of the Recipient.
.CC = nameSpace.CurrentUser.Address;
Also you may find the How To: Fill TO,CC and BCC fields in Outlook programmatically article helpful.
Sub email()
Dim a As Integer
Dim objOutlook As Object
Dim objMail As Object
Dim rngTo As Range
Dim rngCc As Range
Dim rngBcc As Range
Dim rngSubject As Range
Dim rngAttach As Range
Dim rngBody As Range
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
With ActiveSheet
Set rngTo = .Range("B1")
Set rngCc = .Range("B2")
Set rngBcc = .Range("B3")
Set rngSubject = .Range("B4")
Set rngAttach = .Range("B5")
Set rngBody = .Range("B6")
End With
With objMail
.To = rngTo.Value
.Cc = rngCc.Value
.Bcc = rngBcc.Value
.Subject = rngSubject.Value
.Attachments.Add rngAttach.Value
.Body = rngBody.Value
.Display
End With
Set objOutlook = Nothing
Set objMail = Nothing
Set rngTo = Nothing
Set rngCc = Nothing
Set rngBcc = Nothing
Set rngSubject = Nothing
Set rngAttach = Nothing
Set rngBody = Nothing
End Sub
I know this is kind of old, but I ended up here, so someone else might!
I was able to get the sender CC'd using the namespace (at least in an exchange environment). In my case, the CurrentUser. The address returned a string like the following:
/o=ExchangeLabs/ou=Exchange Administrative Group (XXXXXXXXXXXXXXXX)/cn=Recipients/cn=XXXXXXXXXXXXXXXXXXXXXXXXXXXXX-XXXXXXX
This was resolved successfully, and successfully CC'd the sender.
Might also look at Get sender's email address with Excel VBA
Sub TestCC()
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim OutNS As Outlook.Namespace
' Get open Outlook, or create a new instance
On Error Resume Next
Set OutApp = GetObject(, "Outlook.Application")
If OutApp Is Nothing Then Set OutApp = CreateObject("Outlook.Application")
On Error GoTo 0
' Get MAPI Namespace
Set OutNS = OutApp.GetNamespace("MAPI")
' Create Mail Item
Set OutMail = OutApp.CreateItem(olMailItem) 'Item type 0
' Build email
On Error Resume Next
With OutMail
.To = "first.last#email.com"
.CC = OutNS.CurrentUser.Address
.BCC = ""
.Subject = "Email Subject Line"
.Body = "Body Text"
' Resolve added recipients
.Recipients.ResolveAll
' Display or Send created email
.Display
'.Send
End With
' Clean up
Set OutMail = Nothing
Set OutNS = Nothing
Set OutApp = Nothing
End Sub