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
Related
I am trying to copy multiple charts from Excel into Outlook, each as a bitmap, and each on its line and of the same size. The code below loops through copying each chart and successfully pasting them all as bitmaps into Outlook. However, they all occur right next to each, 1-3 in a row depending on size. I have tried adding vbNewLine, vbCrLF, and <br> as well as a few others but they all delete all the charts. Any ideas on how to get each chart on its own line so they are vertically stacked in the e-mail and of the same size? Here is the code. Thanks in advance:
Public Sub EmailCharts()
Dim Sht As Excel.Worksheet
Set Sht = ThisWorkbook.ActiveSheet
Dim OutApp As Object
Set OutApp = CreateObject("Outlook.Application")
Dim outMail As Object
Set outMail = OutApp.CreateItem(0)
Dim vInspector As Object
Set vInspector = outMail.GetInspector
Dim wEditor As Object
Set wEditor = vInspector.WordEditor
Dim objChart As Excel.ChartObject
With outMail
.Display
.to = "abc#xyz.com"
.BCC = "abc#xyz.com"
.Subject = "Subject"
For Each objChart In Sht.ChartObjects
objChart.CopyPicture (xlBitmap)
.HTMLBody = wEditor.Range(0, 0).Paste
Next
End With
Set outMail = Nothing
Set OutApp = Nothing
End Sub
In your code you mixed different approaches when dealing with a MailItem body.
.HTMLBody = wEditor.Range(0, 0).Paste
The Range.Paste method from the Word object model doesn't return any HTML string which can be assigned to the HTMLBody property. So, you need to use one or another, but not two together. I thin the Word object model is much simpler to use (the Paste method), you just need to choose a different place for each image.
The Outlook object model supports three main ways of customizing the message body:
The Body property returns or sets a string representing the clear-text body of the Outlook item.
The HTMLBody property of the MailItem class returns or sets a string representing the HTML body of the specified item. Setting the HTMLBody property will always update the Body property immediately. For example:
Sub CreateHTMLMail()
'Creates a new e-mail item and modifies its properties.
Dim objMail As Outlook.MailItem
'Create e-mail item
Set objMail = Application.CreateItem(olMailItem)
With objMail
'Set body format to HTML
.BodyFormat = olFormatHTML
.HTMLBody = "<HTML><BODY>Enter the message text here. </BODY></HTML>"
.Display
End With
End Sub
The Word object model can be used for dealing with message bodies. See Chapter 17: Working with Item Bodies for more information.
Note, the MailItem.BodyFormat property allows you to programmatically change the editor that is used for the body of an item.
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 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
I have some VBA code that I'm using to send texts from Outlook to team members of my project at work. For some background: for non-AT&T subscribers, we have no issue sending text messages from Outlook by plugging in peoples' numbers en masse into the To: field of Outlook emails. However, all AT&T subscribers will receive the text as a group message, which we want to avoid. The non-AT&T subscribers correctly receive individual texts when we do a group send.
We've written some VBA code to loop through a spreadsheet of AT&T numbers so that Outlook sends one email per AT&T number. This has been working fine for us, however, we were hoping to add some emojis into the texts that we're sending. I've done a lot of Googling and searching through stackoverflows questions, and I can't seem to find any code built for this purpose. I'm also a complete noob when it comes to VBA, and I've pieced this solution together thus far from getting help from a coworker and reading through threads on the internet. This bit about emojis has given me enough trouble that I thought I'd break down and submit this post.
For reference, here is my code:
Sub EmojiTest()
Dim objOutlook As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookRecip As Outlook.Recipient
Dim MobileNumber As String
' Create the Outlook session.
Set objOutlook = CreateObject("Outlook.Application")
Set xlApp = CreateObject("Excel.Application")
'Grab list from Excel
Set xlAtt = xlApp.Workbooks.Open("C:\Users\Username\Desktop\Spreadsheet with AT&T numbers.xlsx")
xlAtt.Activate
LastRow = xlAtt.ActiveSheet.Range("B" & xlAtt.ActiveSheet.Rows.Count).End(-4162).Row
For i = 1 To LastRow
xlAtt.Activate
MobileNumber = xlAtt.ActiveSheet.Range("B" & i).Value
' Create the message.
Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
objOutlookMsg.SentOnBehalfOfName = "TeamAccount#work.com"
With objOutlookMsg
' Add the To recipient(s) to the message.
Set objOutlookRecip = .Recipients.Add(MobileNumber)
objOutlookRecip.Type = olTo
' Set the Subject, Body, and Importance of the message.
.Subject = "Emoji Test"
.Body = "Text with emojis"
.Save
.Send
End With
Next i
Set objOutlook = Nothing
xlApp.Workbooks.Close
Set xlApp = Nothing
End Sub
This is code I never could have come up with myself due to my complete lack of experience with VBA, and limited experience coding in general. Any help is much appreciated.
Change:
.Body = "Text with emojis"
To:
.Body = "\ud83d\ude03"
Full list available here. Copy the box called Java escape string.
The \u escapes the unicode sequence, so typing "\u" and the UTF-16 sequence should let you insert any Emoji.
Some Emojis are actually 2 seperate char sequences, so you have to chain them together.
There is a solution at this link.
As per this, you paste smiley in an Excel cell and then read the cell value, it will be string with length 2, find the code of these 2 characters using AscW() and then chain them using Chrw, e.g. to have a smiley you can use ChrW(-10179) & ChrW(-8638).
I got it!
Sub EmojiTest()
Dim objOutlook As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookRecip As Outlook.Recipient
Dim MobileNumber As String
Dim strbody As String
' Create the Outlook session.
Set objOutlook = CreateObject("Outlook.Application")
Set xlApp = CreateObject("Excel.Application")
'Grab list from Excel
Set xlAtt = xlApp.Workbooks.Open("C:\Users\user\Desktop\Spreadsheet.xlsx")
xlAtt.Activate
LastRow = xlAtt.ActiveSheet.Range("B" & xlAtt.ActiveSheet.Rows.Count).End(-4162).Row
For i = 1 To LastRow
xlAtt.Activate
MobileNumber = xlAtt.ActiveSheet.Range("B" & i).Value
' Create the message.
Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
objOutlookMsg.SentOnBehalfOfName = "Team#work.com"
strbody = "<BODY style=font-size:11pt;font-family:Segoe UI Symbol>🎉Congrats!<p>Paragraph 2.<p>Paragraph 3.</BODY>"
With objOutlookMsg
' Add the To recipient(s) to the message.
Set objOutlookRecip = .Recipients.Add(MobileNumber)
objOutlookRecip.Type = olTo
' Set the Subject, Body, and Importance of the message.
.Subject = "Emoji Test"
.HTMLBody = strbody
.Save
.Send
End With
Next i
Set objOutlook = Nothing
xlApp.Workbooks.Close
Set xlApp = Nothing
End Sub
Basically, I had to convert my message into HTML. I did that using, "Dim strbody As String" at the top, and then using ".HTMLBody = strbody" in my With statement. Once I did that, it was trivial to use the HTML hex code to enter in my emoji. Here is a page with the HTML hex code that I used (🎉): http://www.fileformat.info/info/unicode/char/1f389/index.htm.
Learned a lot about using VBA doing this, so it was fun.
Thanks for your help Sam.
I am trying to write a simple program to automatically send emails from a list in excel, and it works, but outlook keeps opening pop ups asking for permission. How do you get outlook to not ask for permission anymore and just do what excel tells it without the pop ups
Heres the code I have so far:
Sub SendMessage()
Dim objOutlook As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookRecip As Outlook.Recipient
Dim objOutlookAttach As Outlook.Attachment
Dim recemail
Dim i As Integer
i = 1
recemail = Sheet1.Cells(i, 1)
' Create the Outlook session.
Set objOutlook = CreateObject("Outlook.Application")
' Create the message.
Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
With objOutlookMsg
' Add the To recipient(s) to the message.
Set objOutlookRecip = .Recipients.Add(recemail)
objOutlookRecip.Type = olTo
' Set the Subject, Body, and Importance of the message.
.Subject = "TEST!"
.Body = "DOES THIS WORK!?"
' Should we display the message before sending?
If DisplayMsg Then
.Display
Else
.Save
.Send
End If
End With
Set objOutlook = Nothing
i = i + 1
End Sub
This is a manual operation that you need to do :
Run Outlook as Administrator
Go to Tools (Outlook 2007) or File, Options (Outlook 2010 and up)
Go to Trust Center
Change the Programmatic Access setting to : Never warn me about suspicious activity
You can now close Outlook and from now on, you'll have access every time without the popup!
BTW, to avoid opening a new instance of Outlook (if there is already one), use this :
'Create or Get the Outlook session.
On Error Resume Next
Set objOutlook = GetObject(, "Outlook.Application")
If Err.Number > 0 Then Set objOutlook = CreateObject("Outlook.Application")
On Error GoTo 0