Body missing from first email in list sent using VBA - vba

I'm working on a way to send emails to a list of recipients. All emails should contain the same body, but with unique attachments. The code I'm using successfully retrieves the addresses from column N, and inserts attachments based on paths in corresponding rows in columns O:AZ.
The issue I'm encountering is that the first email created using the code has no body. The recipient and attachments are correct, but the email itself is empty. All other emails created show the body correctly. I have very little experience with VBA, and cannot find what's causing the issue.
Any help regarding the code and possible issues would be appreciated! Please let me know if you need more details regarding the code or data.
Sub create_emails()
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
Dim rng As Range
Dim strobody As String
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set sh = Sheets("Sheet2")
Set OutApp = CreateObject("Outlook.Application")
For Each cell In sh.Columns("N").Cells.SpecialCells(xlCellTypeConstants) 'email addresses located in Sheet2, column N
Set rng = sh.Cells(cell.Row, 1).Range("O1:AZ1") 'File paths stored in corresponding rows, columns 0:AZ
If cell.Value Like "?*#?*.?*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
.SentOnBehalfOfName = "xxx#xxx.xxx"
.To = cell.Value
.Subject = "test subject"
.Body = strbody
strbody = "Test text"
For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
.Attachments.Add FileCell.Value
End If
End If
Next FileCell
.Display 'Or use .Display / .Send
End With
Set OutMail = Nothing
End If
Next cell
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub

You're setting strbody after you're using it, so the first time it's used it's empty.
Change:
With OutMail
.SentOnBehalfOfName = "xxx#xxx.xxx"
.To = cell.Value
.Subject = "test subject"
.Body = strbody
strbody = "Test text"
To:
With OutMail
.SentOnBehalfOfName = "xxx#xxx.xxx"
.To = cell.Value
.Subject = "test subject"
strbody = "Test text"
.Body = strbody
And also, if you had Option Explicit set, you'd notice that your declaration for strbody is mistyped to strobody.

Related

Replace content in oft template when sending through vba excel

I am trying to send mails automatically with an outlook template making minor changes to the text linked to the excel file. But the results do not appear when I choose an HTML format. Here is my code: I think the problem is with the .HTMLbody line because everything else in the code works fine. Could someone help?
Sub Test1()
'Working in Office 2000-2016
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim cell As Range
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItemFromTemplate("C:\Users\600008809\Desktop\Reminder emails\Initial Survey.oft")
On Error GoTo cleanup
For Each cell In Columns("G").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*#?*.?*" And _
LCase(Cells(cell.Row, "H").Value) = "yes" _
And LCase(Cells(cell.Row, "I").Value) <> "send" Then
'Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = cell.Value
.Subject = "abc!"
.BodyFormat = olFormatHTML
.HTMLBody = Replace(.HTMLBody, "<< HiringManager >>", Worksheets("Tool").Range(4, 2))
'You can add files also like this
'.Attachments.Add ("C:\test.txt")
Set .SendUsingAccount = OutApp.Session.Accounts.Item("abc#xyz.com")
.Send
'.Display 'Or use Display
End With
On Error GoTo 0
Cells(cell.Row, "I").Value = "send"
Set OutMail = Nothing
End If
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
This line is not good:
.HTMLBody = Replace(.HTMLBody, "<< HiringManager >>", Worksheets("Tool").Range(4, 2)
You have to replace the range value, or cell value in here so you should use
.HTMLBody = Replace(.HTMLBody, "<< HiringManager >>", Worksheets("Tool").cells(4, 2).value

How to paste mulple excel range as picture to outlook at the same time

please help me fix this. I'm new to this area and I would like to paste multiple set of range from excel and paste it onto an outlook email with modified size. Please help me. Thanks in advance!
Here's my current code:
Sub EmailSend()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim StrBody As String
StrBody = "Please see our current Report"
Set rng = Nothing
On Error Resume Next
'Only the visible cells in the selection
'Set rng = Selection.SpecialCells(xlCellTypeVisible)
'You can also use a fixed range if you want
Set rng = Range("C4:D8").SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "x"
.CC = "x"
.BCC = "x"
.Subject = "RRF for Vendor Sourcing - " & Cells(3, 2)
.HTMLBody = StrBody & RangetoHTML(rng)
.Display 'or use .Display
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
This line of code is what defines your range.
Set rng = Range("C4:D8").SpecialCells(xlCellTypeVisible)
You can simply define another range :
Dim rng2 As Range
Set rng2 = Range("J4:N8").SpecialCells(xlCellTypeVisible)
and then make another call to RangetoHTML() using that second range:
RangetoHTML(rng2)
which will return another string of html which you can then concatenate like this:
.HTMLBody = StrBody & RangetoHTML(rng) & "<br>" & RangetoHTML(rng2)

Excel-outlook VBA 2013 not working on 2016 Outlook version

I'm having problems with a macro. It used to work on the 2013 version of outlook and excel but for some reason the CC function has stopped working and I keep getting errors.
With the 2013 version I used the following code to define the CC and BCC:
Set sh = Sheets ("Sheet1")
.to = cell.Value
.CC = sh.Cells(cell.Row, 1).Range("C1:C1")
.BCC = sh.Cells(cell.Row, 1).Range("D1:D1")
This however doesn't work in the 2016 version of my excel and outlook. Every single row in excel need to have its own To , CC and BCC selected from a row in Excel. For some reason it keeps saying CC is not a valid method. object_Mailitem failed.
Editing the variables behind the .cc and .bcc to "mail#x.com" is working without getting the error. So I assume there is something wrong with the line after the .cc, i've tried multiple solutions which ended up in either the same error or an other error telling me it doesn't recognize the .Send command.
EDIT: added the full code of the macro
Sub Send files()
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
Dim rng As Range
Dim ccontvangen As Range
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set sh = Sheets("Sheet1")
Set OutApp = CreateObject("Outlook.Application")
For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
Set rng = sh.Cells(cell.Row, 1).Range("E1:Z1")
If cell.Value Like "?*#?*.?*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = cell.Value
.cc = "x"
.Subject = "Subject"
.Attachments.Add "G:\signature.png", olByValue, 0
.Body = " "
For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
.Attachments.Add FileCell.Value
End If
End If
Next FileCell
.Send
End With
Set OutMail = Nothing
End If
Next cell
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
I had encountered a similar issue where the Subject Line, To, and Cc were not being listed completely.
I figured out the problem by adding a & ";" to the end of each field.

Can't send multiple Outlook Messages

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

Send Email To Recipient List Excel

I want to send an automatically from Excel as it is running reports, but I need it to do a VLOOKUP on the client name and select all email addresses that are assigned to that client. Can you help please?
So I will have a table such as below, on a sheet named Client Emails
Company 1 | example#mail.com
Company 1 | example2#mail.com
Company 2 | somebody#somewhere.com
Company 3 | you#here.com
Company 1 | him#there.com
to make it easier to keep up to date. Right now I have the below code which sends the email correctly, but I would like it to pull the addresses from workbook and not the code as it is easier to update this way.
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = "example#mail.com; example2#mail.com"
.CC = ""
.BCC = ""
.Subject = "Subject"
.Body = "Hello World."
.Attachments.Add ("Attachment")
'.Display
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
You could set up a loop to look through the table of email address and concatenate the emails of matching companies into a string variable which you then use for the "to" section.
For example (inserted prior to your with statement):
Dim Lastrow as long
dim myemail as string
dim myrange as Range
'counts the number of rows in use
lastrow = Sheets("Client Emails").Cells(Rows.Count, 1).End(xlUp).Row
For Each myrange In Sheets("Client Emails").Range("A2:A" & lastrow)
If myrange = "Company1" then
myEmail = myEmail & myrange.offset(0,1).value & ";"
End if
Next Myrange
You would replace "Company1" in the above to be the name of the company you were currently emailing.
The in your existing code replace:
.To = Email1, Email2,email3, .........
With
.To = myEmail
company = cells(1,2) ' Assign the source cell value of company name like VLOOKUP reference
a = 2
do while cells(a,1)<>""
if company = cells(a,1) then tolist = cells(a,2) 'IF condition matches, To mail list will be assigned to tolist
a = a +1
loop
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = tolist
.CC = ""
.BCC = ""
.Subject = "Subject"
.Body = "Hello World."
.Attachments.Add ("Attachment")
'.Display
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing