Paste Excel range into Outlook - excel

I'm upgrading an Excel macro. I want to generate an email copying in a table that changes range daily.
Strbody populates the email but the timetable isn't attaching.
Sub Ops_button()
'Working in Office 2000-2010
Dim Outapp As Object
Dim Outmail As Object
Dim Strbody As String
Dim Timetable As String
'Auto Email Attachment Variables
Set Outapp = CreateObject("Outlook.Application")
Set Outmail = Outapp.createitem(0)
Timetable = Sheets("sheet1").Range("C2").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Strbody = "body text."
On Error Resume Next
With Outmail
'Send email
.To = ""
.bcc = ""
.Subject = "Report" & " " & Format$(Date, "dd-mm-yyyy")
.body = Strbody & Timetable
On Error Resume Next
.Display
End With
On Error GoTo 0
Set Outmail = Nothing
Set Outapp = Nothing
End Sub

You can't do this the way you're trying to do it... Let's see why not :)
You've declared Timetable as a String type variable. In this statement, you're assigning its value as the return from the .Select method (which will return a value of True if there is no error).
Timetable = Sheets("sheet1").Range("C2").Select
So, you're in no way appending the Table's Range object to the string, in this statement:
.body = Strbody & Timetable
Instead, you really need to either convert the table to HTML or copy and paste the range directly from Excel to Word.
Use Ron de Bruin's function to convert the table to an HTML PublishObject and insert that to the email, or
.Display the MailItem and then get a handle on the MailItem's .Inspector object (which is really just a Word document)
For the solution 1, adapt the answer already given, here:
Paste specific excel range in outlook
For the solution 2, you'll need to use the method outlined here to get the Inspector (Word Document representing the Email item):
https://msdn.microsoft.com/en-us/library/office/ff868098.aspx
Then, Dim TimeTable as Range, and change code to:
Set Timetable = Sheets("sheet1").Range("C2").End(xlToRight).End(xlDown)
Then, copy the table:
Timetable.Copy
And then following the MSDN link above once you have a handle on the Inspector, get the destination range in Outlook (Word) and you can use the PasteAndFormat method of a Word.Range object:
Dim wdRange as Object 'Word.Range
OutMail.Display
Set wdRange = OutMail.getInspector().WordEditor.Range
wdRange.Text = strBody
wdRange.Expand (1)
wdRange.Characters.Last.PasteAndFormat 16 'wdFormatOriginalFormatting
Option 2 would be my preferred method. I'm on a computer that doesn't have outlook, so I'm winging this a little bit from memory and I can't test right now, but if you have any issues with it just leave a comment and I'll try to help out some more in the morning.

Related

Generate an email with a range from a worksheet?

I'm new to this and got my first Excel macro working yesterday. I've create a command button on Excel to set up an email and I want to send a range from the worksheet. I would like it to keep the formatting if possible. I believe the issue is with:
xMailBody = ThisWorkbook.Activeworksheet("Sheet1").Range("AA65:AE67")
Everything else worked okay.
Thank you very much.
Sonny
Private Sub CommandButton1_Click()
'Updated by 2022/09/16
Dim xOutApp As Object
Dim xOutMail As Object
Dim xMailBody As String
On Error Resume Next
Set xOutApp = CreateObject("Outlook.Application")
Set xOutMail = xOutApp.CreateItem(0)
xMailBody = ThisWorkbook.Activeworksheet("Sheet1").Range("AA65:AE67")
On Error Resume Next
With xOutMail
.To = Range("AD69")
.CC = ""
.BCC = ""
.Subject = Range("AD70")
.Body = xMailBody
.Display 'or use .Send
End With
On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing
End Sub
You have xMailBody declared as a string then are stating that it is the desired range.
Try DIMing it as a range!
First of all, I've noticed that you are trying to set the Body property which is a plain text string:
.Body = xMailBody
If you need to preserve formatting you can create a well-formed HTML formatting and then assign it to the HTMLBody prperty of Outlook items.
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. In that case you can just copy the required range in Excel and then paste to the message directly using the Paste method from the Word object model. See Chapter 17: Working with Item Bodies for more information.
Also you may consider using the RangetoHTML function to convert Excel data to the HTML markup.

Pasting Multiple Excel Charts One Per Row with VBA in Outlook

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.

Paste in Outlook an excel range

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

Pulling multiple emails from data table & making separate emails based on the same template

I am trying to pull email addresses from a column in an Excel Data table and have those email addresses be the receiver of email based on a template.
Code I made below.
Sub Mail_experiment()
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.Mailtem
Set OutApp = CreateObject("Outlook.Application")
Set = OutMail
OutApp.CreatItemFromTemplate("C:\Users\Name\Documents\Project\PO Accrual Support Email Template.oft")
On Error Resume Next
With OutMail
.To = "J.Doe#gmail.com"
.CC = ""
.BC = ""
.Subject = ""
.Save
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
All separate emails will be sent later, hence .Save. Also, I am attempting to pull what would be the subject line of the email from another column in the data table.
How would I achieve both concepts with what I have so far?
You should create a function that returns a new MailItem based on your template. In this way, you will be able to test the new MailItem separately without having to run the complete code.
I like to enumerate my excel columns. This makes it both easier to refer to the correct column and to update the code if the column order is changed.
Option Explicit
'Enumeration is by defination the action of establishing the number of something
'I Enumerate my Worksheet Columns to give them a meaningful name that is easy to recognize
Public Enum EmailColumns
ecEmailAdresses = 1
ecSubject = 3
End Enum
Public Sub SaveEmails()
Dim r As Long
'The With Statement allows you to "perform a series of statements on a specified object without specifying the name of the object multiple times"
'.Cells(.Rows.Count, ecEmailAdresses).End(xlUp).Row actually refers to ThisWorkbook.Worksheets("Support Emails").Cells(.Rows.Count, ecEmailAdresses).End(xlUp).Row
With ThisWorkbook.Worksheets("Support Emails")
'.Cells(): references a cell or range of cells on Worksheets("Support Emails")
'.Cells(.Rows.Count, ecEmailAdresses): Refrences the last cell in column 1 of the worksheet
'.End(xlUp): Changes the refererence from the last cell to the first used cell above the last cell in column 3
'.Cells(.Rows.Count, ecEmailAdresses).End(xlUp).Row: returns the Row number of the last used cell in column 3
For r = 2 To .Cells(.Rows.Count, ecEmailAdresses).End(xlUp).Row
getPOAccrualTemplate(MailTo:=.Cells(r, ecEmailAdresses), Subject:=.Cells(r, ecEmailAdresses)).Save
Next
End With
End Sub
Public Function getPOAccrualTemplate(MailTo As String, Optional CC As String, Optional BCC As String, Optional Subject As String) As Object
Const TEMPLATE_PATH As String = "C:\Users\Name\Documents\Project\PO Accrual Support Email Template.oft"
Dim OutApp As Object, OutMail As Object
' CreateObject("Outlook.Application"): Creates an instance of an Outlook Application.
' Outlook.Application.CreateItemFromTemplate returns a new MailItem Based on a saved email template
Set OutMail = CreateObject("Outlook.Application").CreateItemFromTemplate(TEMPLATE_PATH)
With OutMail
.To = MailTo
.CC = CC
.BCC = BCC
.Subject = Subject
End With
'Returns the new MailItem to the caller of the function
Set getPOAccrualTemplate = OutMail
End Function
Immediate Window Tests
'Test getPOAccrualTemplate
' Assign Values to Varaible
MailTo = "ti#stackoverflow.com"
CC = "efrenreyes#youdontwantnoneson.com"
BCC = "alexp#gmail.com"
Subject = "Who is going to the tournament tonight?"
'Test Variables using "," to insert Tabs between values
?MailTo, CC, BCC, Subject
?MailTo;"-";CC;"-";BCC;"-";Subject
'Pass variables into getPOAccrualTemplate and return a new MailItem based on the template
'variables created in the immediate window are Variant Type
'CStr is used to cast the values to Strings
set OutMail = getPOAccrualTemplate(CStr(MailTo), CStr(CC), CStr(BCC), CStr(Subject))
'Find out what type of object was returned
?TypeName(OutMail)
'Display the Mail Item
OutMail.Display
'Test Enumerate Columns
Columns(EmailColumns.ecEmailAdresses).Select
Columns(ecSubject).Select
MailTo = Cells(2, ecEmailAdresses)
CC = ""
BCC = ""
Subject = Cells(2, ecSubject)
'Test the function directly
getPOAccrualTemplate(CStr(MailTo), CStr(CC), CStr(BCC), CStr(Subject)).Display
'Test SaveEmails() Make sure and add a breakpoint
SaveEmails
?.Cells(.Rows.Count, ecEmailAdresses).End(xlUp).Row
Video Tutorials
These are two videos from my favorite VBA tutorial series that are relevant:
Excel VBA Introduction Part 5 - Selecting Cells (Range, Cells, Activecell, End, Offset)
Excel VBA Introduction Part 26 - Constants and Enumerations (Const, Enum)
You should just slightly refactor your code. The macro sending the email should take (at least) the email adress and the subject in parameter:
Sub Mail_experiment(ByVal address As String, ByVal subject As String)
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.Mailtem
Set OutApp = CreateObject("Outlook.Application")
Set = OutMail
OutApp.CreatItemFromTemplate("C:\Users\Name\Documents\Project\PO Accrual Support Email Template.oft")
On Error Resume Next
With OutMail
.To = address '<-- use the input here
.CC = ""
.BC = ""
.Subject = subject '<-- use the input here
.Save
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Hence, supposing you have the email addresses in the column A and the subjects in the column B (from 1 to 10, for example), you'd just need to call the macro in a loop:
For j = 1 To 10
Mail_experiment Range("A" & j), Range("B" & j)
Next j
The above will call the Mail_experiment macro 10 times, each time passing a new parameter (A1 - B1, then A2 - B2 etc.)

Insert dynamic hyperlink from cell reference and place it above a copied range

I'm running a report that gets distributed via email. In the email is a hyperlink to the report and a range of cells copied out of it as a snapshot of the report content. I'm trying to automate and found some VBA, but I'm not a programmer and can't modify it for my needs.
The VBA below gets me most of the way, but for 2 shortcomings:
1) I need the hyperlink to point to the specific file I'm referencing in the email, which changes daily (i.e. a unique workbook is created). The below uses a static hyperlink. I was trying to figure out a way to derive the hyperlink from a cell reference.
2) When copying the hyperlink and range of cells from excel into the email, I need the cells below the hyperlink. The below puts the range above the hyperlink.
I'd like to preserve the approach taken in the below VBA of referencing a worksheet to derive the email. It appears easy to deploy on other reports which get distributed.
Sub CreateMail()
Dim rngSubject As Range
Dim rngTo As Range
Dim rngCc As Range
Dim rngBody As Range
Dim objOutlook As Object
Dim objMail As Object
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
With ActiveSheet
Set rngTo = .Range("B1")
Set rngCc = .Range("B3")
Set rngSubject = .Range("B2")
Set rngBody = .Range("H6:K22")
End With
rngBody.Copy
With objMail
.Body = "Please click on the link below..." & vbCrLf & "rngBody.Paste" & vbCrLf & _
"file:\\dbd03\nccode\Router_Proc\04Routing.txt"
End With
With objMail
.To = rngTo
.Cc = rngCc
.Subject = rngSubject
.Display
End With
SendKeys "^({v})", True
Set objOutlook = Nothing
Set objMail = Nothing
1) To make the file link dynamic, you can just include the reference of the cell, containing the file name, in the file path.
"<file:\\dbd03\nccode\Router_Proc\" & _
ActiveSheet.Range(<cell address here>) & ">"
Note: You might want to also check to make sure the path exists (like this) before putting it in the email
2) To paste the cells below the hyperlink, you can use another SendKeys combination to simulate the pressing of Ctrl + End, which will place the cursor at the end of the email. Doing this before using SendKeys to simulate the Ctrl + V should paste the range of cells after your body text. Your updated code should be the following:
With objMail
.To = rngTo
.Cc = rngCc
.Subject = rngSubject
.Display
End With
SendKeys "^({END})", True '<--- Add this line HERE
SendKeys "^({v})", True
Another Note: Also, i don't think you need "rngBody.Paste" in your Body string, as this just pastes that exact text in your email body

Resources