I have a user who sends eMails to a large "To" list, Sometimes over 20 addresses. With this large a "To" list, the received mail sometimes ends up on the recipient's SPAM folder. Obviously, we'd like to avoid this.
My idea is to have the user create an original eMail and then run a Macro. The Macro would loop through all the eMail addresses in an Excel worksheet and then copy the original message and send it to each recipient individually.
I'm unsure as to how to copy a MailItem from the original to a new MailItem. The Excel looping works fine.
Here's my abbreviated macro:
Option Explicit
Sub Send_emails()
'.
'.
Set objDoc = objInspector.WordEditor
Set objWrdApp = objDoc.Application
Set objSelection = objWrdApp.Selection
'Loop through the Rows in the worksheet. Start at row 2 to ignore header
For lngCurrSheetRow = 2 To lngLastSheetRow
strEmailAddress = objWorksheet.Cells(lngCurrSheetRow, 1).Value
'Set objNewMail so that the new message is created and can be referenced.
Set objNewMail = Application.CreateItem(0)
With objNewMail
.Body = objSelection
.To = strEmailAddress
End With
Next lngCurrSheetRow
'.
'.
End Sub
To copy mailitem.body Example would be
Option Explicit
Sub Send_emails()
Dim olMsg As Outlook.MailItem
Set olMsg = ActiveExplorer.Selection.Item(1)
Dim objNewMail As Outlook.MailItem
Set objNewMail = Application.CreateItem(0)
With objNewMail
.Body = olMsg.Body
.Display
End With
End Sub
For HTML Body simply do HTMLBody = olMsg.HTMLBody
Related
I'm trying to do a "reply all" command using a specific template.
This is what I have so far:
Sub my_test()
Dim mail 'object/mail item iterator
Dim replyall 'object which will represent the reply email
For Each mail In Outlook.Application.ActiveExplorer.Selection
If mail.Class = olMail Then
Set replyall = mail.replyall
With replyall
.Body = "My template from a oft file"
.Display
End With
End If
Next
End Sub
In the body, I'd like to use a template which I have in a oft file in c:\mytemplate.oft.
When I reply, in the bottom I want the original email and in the top of the email body I want the text from the existing template.
The idea is to use this code (if possible), and place the context of the template body file (text and a table), inside of this reply email (in the top).
Code for Outlook. No apparent purpose for the Excel tag.
Option Explicit
Sub my_test()
Dim objItem As Object
Dim mail As MailItem
Dim replyall As MailItem
Dim templateItem As MailItem
For Each objItem In ActiveExplorer.Selection
If objItem.Class = olMail Then
Set mail = objItem
Set replyall = mail.replyall
Set templateItem = CreateItemFromTemplate("C:\template.oft")
With replyall
.HTMLBody = templateItem.HTMLBody & .HTMLBody
.Display
End With
End If
Next
End Sub
I'm trying to use VBA to paste a selected range from Excel to Outlook. I want to keep it under the same conversation with all the recipients.
I have seen some codes: Outlook Reply or ReplyAll to an Email
I am stuck with this code (Application.ActiveExplorer.Selection).
Any ideas how to do this?
This is the code I have when creating a new email instead of replying:
Sub a()
Dim r As Range
Set r = Range("B1:AC42")
r.Copy
'Paste as picture in sheet and cut immediately
Dim p As Picture
Set p = ActiveSheet.Pictures.Paste
p.Cut
'Open a new mail item
Dim outlookApp As Outlook.Application
Set outlookApp = CreateObject("Outlook.Application")
Dim outMail As Outlook.MailItem
Set outMail = outlookApp.CreateItem(olMailItem)
'Get its Word editor
outMail.Display
Dim wordDoc As Word.Document
Set wordDoc = outMail.GetInspector.WordEditor
With outMail
.BodyFormat = olFormatHTML
.Display
'.HTMLBody = "write your email here" & "<br>" & .HTMLBody
.Subject = ""
.Attachments.Add ("path")
End With
'Paste picture
wordDoc.Range.Paste
For Each shp In wordDoc.InlineShapes
shp.ScaleHeight = 50 shp.ScaleWidth = 50
Next
End Sub
EDIT:
I noticed that your question was edited by another user and now the mention of your need for the email to be a reply-all email is gone. This was probably in order to make your question simpler, but now my answer won't make as much sense. My answer also assumes that you also already have the HTML code needed to insert the email. If that's not the case, you might want to have a look at this gist to get you started on converting a range to HTML code.
The question you are linking to was on Outlook VBA so you have to make sure that you declare your variables differently since in Excel VBA, Application will refer to the Excel application and not Outlook.
Here's how you could go about this:
Sub ReplyAllWithTable()
Dim outlookApp As Outlook.Application
Set outlookApp = CreateObject("Outlook.Application")
Dim olItem As Outlook.MailItem
Dim olReply As MailItem ' ReplyAll
Dim HtmlTable As String
HtmlTable = "<table><tr><td>Test</td><td>123</td></tr><tr><td>123</td><td>test</td></tr></table>"
For Each olItem In outlookApp.ActiveExplorer.Selection
Set olReply = olItem.ReplyAll
olReply.HTMLBody = "Here is the table: " & vbCrLf & HtmlTable & vbCrLf & olReply.HTMLBody
olReply.Display
'Uncomment next line when you're done with debugging
'olReply.Send
Next olItem
End Sub
About pasting range as a picture
If you take the approach in the code above, you won't be able to use the copy-paste method to insert your image. I personally prefer to set the HTML body of the email instead since it gives you more control. If you are ok with using the HTML method you could either:
convert your range to HTML code and insert it inside the email (similarly as how it was done in the code above); or
convert your range to an image, save it and insert it with HTML in the email body.
In order to achieve the 2nd option, you could run the following code:
Sub ReplyAllWithTableAsPicture()
'REFERENCE:
'- https://excel-macro.tutorialhorizon.com/excel-vba-send-mail-with-embedded-image-in-message-body-from-ms-outlook-using-excel/
Dim outlookApp As Outlook.Application
Set outlookApp = CreateObject("Outlook.Application")
Dim olItem As Outlook.MailItem
Dim olReply As MailItem ' ReplyAll
Dim fileName As String
Dim fileFullName As String
fileFullName = Environ("temp") & "\Temp.jpg" 'CUSTOMIZABLE (make sure this file can be overwritten at will)
fileName = Split(fileFullName, "\")(UBound(Split(fileFullName, "\")))
RangeToImage fileFullName:=fileFullName, rng:=ActiveSheet.Range("B1:AC42") 'CUSTOMIZABLE (choose the range to save as picture)
For Each olItem In outlookApp.ActiveExplorer.Selection 'if we have only one email, we could use: set olItem = outlookApp.ActiveExplorer.Selection(1)
Set olReply = olItem.ReplyAll
olReply.Attachments.Add fileFullName, olByValue, 0
olReply.HTMLBody = "Here is the table: " & "<br>" & "<img src='cid:" & fileName & "'>" & vbCrLf & olReply.HTMLBody
olReply.Display
'Uncomment this line when you're done with debugging
'olReply.Send
Next olItem
End Sub
And add the following sub procedure in the module as well:
Sub RangeToImage(ByVal fileFullName As String, ByRef rng As Range)
'REFERENCE:
'- https://analystcave.com/excel-image-vba-save-range-workbook-image/
Dim tmpChart As Chart, n As Long, shCount As Long, sht As Worksheet, sh As Shape
Dim pic As Variant
'Create temporary chart as canvas
Set sht = rng.Worksheet
rng.Copy
sht.Pictures.Paste.Select
Set sh = sht.Shapes(sht.Shapes.Count)
Set tmpChart = Charts.Add
tmpChart.ChartArea.Clear
tmpChart.Name = "PicChart" & (Rnd() * 10000)
Set tmpChart = tmpChart.Location(Where:=xlLocationAsObject, Name:=sht.Name)
tmpChart.ChartArea.Width = sh.Width
tmpChart.ChartArea.Height = sh.Height
tmpChart.Parent.Border.LineStyle = 0
'Paste range as image to chart
sh.Copy
tmpChart.ChartArea.Select
tmpChart.Paste
'Save chart image to file
tmpChart.Export fileName:=fileFullName, FilterName:="jpg"
'Clean up
sht.Cells(1, 1).Activate
sht.ChartObjects(sht.ChartObjects.Count).Delete
sh.Delete
End Sub
Explanations:
In the ReplyAllWithTableAsPicture procedure, we are essentially doing the same thing as the first code, but we are now attaching an image to the email but keep it "hidden" so we can just include it in the body of the email without it being in the list of attachements when people receive the email. To include the image, we use the img tag with a source starting with "cid" allowing us to refer to the "hidden" attachment.
Since the image has to be a file, we use the RangeToImage procedure to generate the image file from the range that we supply. Currently, the file will be saved in the temporary directory always with the same name, which means that the file would be overwritten. Feel free to change the name or add the date to the name if you which to keep copies of these image files.
Instead of creating mail item, Work with Selection item
Example outlookApp.ActiveExplorer.Selection(1)
Your code
Dim outMail As Outlook.MailItem
Set outMail = outlookApp.CreateItem(olMailItem)
'Get its Word editor
outMail.Display
Change to
Dim sel_Item As Outlook.MailItem
Set sel_Item = outlookApp.ActiveExplorer.Selection(1)
Dim outMail As Outlook.MailItem
'Get its Word editor
Set outMail = sel_Item.ReplyAll
I need an excel file to email an exported chart to a varying number of contacts on open. For every email, the chart needs to be refiltered. I figured out how to do this by creating a dynamic chart with a scrollbar and on each iteration of the loop I will at 13 to its position (p).
How do I get my VBA code to send an email with the exported chart to whatever is in column 2? It also is currently only sending one email, rather than however many are in the column. Any help would be awesome.
Private Sub Workbook_Open()
Dim b1 As Workbook, b2 As Workbook
Dim sh As Worksheet
Set b1 = ThisWorkbook
Dim olApp As Object
Dim olMail As Object
Dim i As Long
Dim p As Integer
Dim email As Range
Dim book As Range
Set olApp = CreateObject("Outlook.application")
Set olMail = olApp.createitem(i)
Set book = Range("A1:B9")
p = 1
'START LOOP
For Each email In book.Rows
Sheets("nothing").Range("B1").Select
ActiveCell.FormulaR1C1 = p
Worksheets(1).ChartObjects(1).Activate
ActiveChart.Export "testchartlocation.png"
With olMail
.To = "test#email.com"
.Subject = "Emailer Testing..."
.HTMLbody = "<html><p>Testing...</p><img src='testchartlocation.png'>"
.display
End With
p = p + 13
Application.Wait (Now + TimeValue("0:00:01"))
Next
'END LOOP
'ThisWorkbook.Close False
End Sub
If by
How do I get my VBA code to send an email with the exported chart to
whatever is in column 2?
You mean you have email addresses stored in column 2 that you need to access with each iteration to send the exported chart to, you could change this line
.To = "test#email.com"
To
.To = Cells(email.Row, 2) '<-Make sure to qualify this range with whatever worksheet you're pulling from
Concerning your issue with your email only being generated once, you need to move
Set olMail = olApp.createitem(i) '<- you can change `i` to `0`
Into the beginning of your For-Next loop and set it = Nothing at the end like
For Each email In book.Rows
Set olMail = olApp.createitem(0)
'Do Stuff
Set olMail = Nothing
Next email
That way a new email is generated every iteration.
EDIT:
You can probably get rid of this line
Sheets("nothing").Range("B1").Select
And replace
ActiveCell.FormulaR1C1 = p
With
Sheets("nothing").Range("B1").FormulaR1C1 = p
Since you're working with multiple sheets and .Activate functions, I would recommend qualifying all of your ranges.
I am trying to add the cc function to a mail merge. In other words, I not only need to personalize the emails to different email addresses. I would also like each email to be include a CC that shows the same email to multiple recipients.
Example: the same email to John Doe can be automatically cc'd to his manager.
I tried adding , and ; as well as merging two cells in excel with the addresses and got errors.
I also read an article that shows how to send attachments to multiple recipients and modified it to make the cc work. See article below.
http://word.mvps.org/FAQs/MailMerge/MergeWithAttachments.htm
The code I came up with is shown below. It allowed me to cc, however, it only goes through with the first row of emails and none of the rest. Also the body of the message does not show up.
Any pointers?
Sub emailmergewithattachments()
'Global Config Variables
Dim saveSent As Boolean, displayMsg As Boolean, attachBCC As Boolean
saveSent = True 'Saves a copy of the messages into the senders "sent" box
displayMsg = False 'Pulls up a copy of all messages to be sent - WARNING, do not use on long lists!
attachBCC = False 'Adds third column data into the BCC field. Will throw error if this column does not exist.
Dim Source As Document, Maillist As Document, TempDoc As Document
Dim Datarange As Range
Dim i As Long, j As Long
Dim bStarted As Boolean
Dim oOutlookApp As Outlook.Application
'Dim oOutlookApp As Application
Dim oItem As Outlook.MailItem
'Dim oItem As MailMessage
Dim mysubject As String, message As String, title As String
Set Source = ActiveDocument
' Check if Outlook is running. If it is not, start Outlook
On Error Resume Next
Set oOutlookApp = GetObject(, "Outlook.Application")
If Err <> 0 Then
Set oOutlookApp = CreateObject("Outlook.Application")
bStarted = True
End If
' Open the catalog mailmerge document
With Dialogs(wdDialogFileOpen)
.Show
End With
Set Maillist = ActiveDocument
' Show an input box asking the user for the subject to be inserted into the email messages
message = "Enter the subject to be used for each email message." ' Set prompt.
title = " Email Subject Input" ' Set title.
' Display message, title
mysubject = InputBox(message, title)
' Iterate through the Sections of the Source document and the rows of the catalog mailmerge document,
' extracting the information to be included in each email.
For j = 0 To Source.Sections.Count - 1
Set oItem = oOutlookApp.CreateItem(olMailItem)
' modification begins here
With oItem
.Subject = mysubject
.body = ActiveDocument.Content
.Body = Source.Sections(j).Range.Text
Set Datarange = Maillist.Tables(1).Cell(j, 1).Range
Datarange.End = Datarange.End - 1
.To = Datarange
Set Datarange = Maillist.Tables(1).Cell(j, 2).Range
Datarange.End = Datarange.End - 1
.CC = Datarange
If attachBCC Then
Set Datarange = Maillist.Tables(1).Cell(j, 3).Range
Datarange.End = Datarange.End - 1
.CC = Datarange
End If
For i = 2 To Maillist.Tables(1).Columns.Count
Set Datarange = Maillist.Tables(1).Cell(j, i).Range
Datarange.End = Datarange.End - 1
.Attachments.Add Trim(Datarange.Text), olByValue, 1
Next i
If displayMsg Then
.Display
End If
If saveSent Then
.SaveSentMessageFolder = mpf
End If
.Send
End With
Set oItem = Nothing
Next j
Maillist.Close wdDoNotSaveChanges
' Close Outlook if it was started by this macro.
If bStarted Then
oOutlookApp.Quit
End If
MsgBox Source.Sections.Count - 1 & " messages have been sent."
'Clean up
Set oOutlookApp = Nothing
End Sub
Firstly, I'd separate out your email code, and the code for iterating your spreadsheet.
Here's my take on the email code for outlook (be sure to setup references->outlook object model, as I've used early biding)
Sub SendMessage(recipients As Variant, subject As String, body As String, Optional ccRecips As Variant, Optional bccRecips As Variant, Optional DisplayMsg As Boolean, Optional AttachmentPath As Variant)
Dim objOutlook As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookRecip As Outlook.Recipient
Dim objOutlookAttach As Outlook.Attachment
Dim item As Variant
' Create the Outlook session.
On Error Resume Next
Set objOutlook = GetObject(, "Outlook.Application")
If Err <> 0 Then
Set objOutlook = CreateObject("Outlook.Application")
End If
On error goto 0
' Create the message.
Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
With objOutlookMsg
' Add the To recipient(s) to the message.
For Each item In recipients
Set objOutlookRecip = .recipients.Add(item)
objOutlookRecip.Type = olTo
Next
' Add the CC recipient(s) to the message.
If Not IsMissing(ccRecips) Then
For Each item In ccRecips
Set objOutlookRecip = .recipients.Add(item)
objOutlookRecip.Type = olTo
Next
End If
' Add the BCC recipient(s) to the message.
If Not IsMissing(bccRecips) Then
For Each item In bccRecips
Set objOutlookRecip = .recipients.Add(item)
objOutlookRecip.Type = olBCC
Next
End If
' Set the Subject, Body, and Importance of the message.
.subject = subject
.body = body 'this can also be HTML, which is great if you want to improve the look of your email, but you must change the format to match
' Add attachments to the message.
If Not IsMissing(AttachmentPath) Then
Set objOutlookAttach = .Attachments.Add(AttachmentPath)
End If
' Resolve each Recipient's name -this may not be necessary if you have fully qualified addresses.
For Each objOutlookRecip In .recipients
objOutlookRecip.Resolve
Next
' Should we display the message before sending?
If DisplayMsg Then
.Display
Else
.Save
.Send
End If
End With
Set objOutlook = Nothing
End Sub
A note: Recipients, CC's and BCC's are expecting arrays of values, which may also only be a single value. This means we can probably send it a raw range, or we can load that range into an array, and send it that.
Now that we've built a nice generic way of sending emails (which is handily re-usable) we can think about the logic of the thing we've got sending emails. I've built the below email, but I havn't spent a lot of time on it (or tested it, as it's quite specific to your tables). I believe it should be very close though.
On writing this, I think you'll see the main trick for editing your own however - the key was splitting the text in the CC cell, by the delimiter you are using. This creates an array of addresses, which you can then iterate over and add to the recipient, CC or BCC.
Sub DocumentSuperMailSenderMagicHopefully()
Dim Source As Document, Maillist As Document, TempDoc As Document
Dim mysubject As String, message As String, title As String
Dim datarange As Range 'word range I'm guessing...
Dim body As String
Dim recips As Variant
Dim ccs As Variant
Dim bccs As Variant
Dim j As Integer
Dim attachs As Variant
Set Source = ActiveDocument
With Dialogs(wdDialogFileOpen) 'Hey, I'm not sure what this does, but I'm leaving it there.
.Show
End With
Set Maillist = ActiveDocument
' Show an input box asking the user for the subject to be inserted into the email messages
message = "Enter the subject to be used for each email message." ' Set prompt.
title = " Email Subject Input" ' Set title.
' Display message, title
mysubject = InputBox(message, title)
' Iterate through the Sections of the Source document and the rows of the catalog mailmerge document,
' extracting the information to be included in each email.
'IMPORTANT: This assumes your email addresses in the table are separated with commas!
For j = 0 To Source.Sections.Count - 1
body = Source.Sections(j).Range.Text
'get to recipients from tables col 1 (I'd prefer this in excel, it's tables are much better!)
Set datarange = Maillist.tables(1).Cell(j, 1).Range
datarange.End = datarange.End - 1
recips = Split(datarange.Text)
'CC's
Set datarange = Maillist.tables(1).Cell(j, 2).Range
datarange.End = datarange.End - 1
ccs = Split(datarange.Text)
'BCC's
Set datarange = Maillist.tables(1).Cell(j, 3).Range
datarange.End = datarange.End - 1
bccs = Split(datarange.Text)
'Attachments array, should be paths, handled by the mail app, in an array
ReDim attachs(Maillist.tables(1).Columns.Count - 3) 'minus 2 because you start i at 2 and minus one more for option base 0
For i = 2 To Maillist.tables(1).Columns.Count
Set datarange = Maillist.tables(1).Cell(j, i).Range
datarange.End = datarange.End - 1
attachs(i) = Trim(datarange.Text)
Next i
'call the mail sender
SendMessage recips, subject, body, ccs, bccs, False, attachs
Next j
Maillist.Close wdDoNotSaveChanges
MsgBox Source.Sections.Count - 1 & " messages have been sent."
End Sub
This has turned into a longer post than I was expecting. Good luck with the project!
I had the same issue not being able to CC using the mail merge from Excel, and also wanted to use the BCC field and have subjects that are variable for each email), and didn't find a good tool either, so I built my own tool and have just released it for others to benefit from. Let me know if that solves your issue too: http://emailmerge.cc/
It doesn't handle attachments yet, but I've planned to add that soon.
EDIT: EmailMerge.cc now also handles attachments, high/low priority, read receipts [unfortunately some people still want those ;) ]
I hope this is useful to you, my intent is not to to spam SO ;)
I would like to paste a range of formatted Excel cells into an Outlook message.
The following code (that I lifted from various sources), runs without error and sends an empty message.
Sub SendMessage(SubjectText As String, Importance As OlImportance)
Dim objOutlook As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookRecip As Outlook.Recipient
Dim objOutlookAttach As Outlook.Attachment
Dim iAddr As Integer, Col As Integer, SendLink As Boolean
'Dim Doc As Word.Document, wdRn As Word.Range
Dim Doc As Object, wdRn As Object
' Create the Outlook session.
Set objOutlook = CreateObject("Outlook.Application")
' Create the message.
Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
Set Doc = objOutlookMsg.GetInspector.WordEditor
'Set Doc = objOutlookMsg.ActiveInspector.WordEditor
Set wdRn = Doc.Range
wdRn.Paste
Set objOutlookRecip = objOutlookMsg.Recipients.Add("MyAddress#MyDomain.com")
objOutlookRecip.Type = 1
objOutlookMsg.Subject = SubjectText
objOutlookMsg.Importance = Importance
With objOutlookMsg
For Each objOutlookRecip In .Recipients
objOutlookRecip.Resolve
' Set the Subject, Body, and Importance of the message.
'.Subject = "Coverage Requests"
'objDrafts.GetFromClipboard
Next
.Send
End With
Set objOutlookMsg = Nothing
Set objOutlook = Nothing
End Sub
I think you need to call .Save on your Mail Item (objOutlookMsg) after you've made all the changes.
Put .Display before .Send,
Simple but Quick fix, your problem is the email is not refreshing with the pasted contents before it sends, forcing it to Display first gives it time...
Also make sure you have another macro which runs before this to Copy the Range into your clipboard...
There is a button in excel to do this, "Send to mail recipent" its not normally on the ribbon.
You can also use the simple mapi built into office using the MailEnvelope in VBA
.. a good article on what you are trying to do http://www.rondebruin.nl/mail/folder3/mail4.htm