I'm trying to copy a range of cells as a picture, put that picture in an email, then send the email with an Excel macro.
I'm able to do all of this, however the image comes out smaller/blurrier than the original. I've tried all sorts of copy/paste methods but the results are the same.
When I copy the picture manually with copy as picture (as shown on screen) without a macro, then paste into outlook using just ctrl+v, the image looks fine.
Any idea why this is happening?
Here's the code:
Sub SendMail()
Dim aOutlook As Object
Dim aEmail As Object
Dim rngeAddresses As Range, rngeCell As Range, strRecipients As String
Dim rngeData As Range
Set aOutlook = CreateObject("Outlook.Application")
Set aEmail = aOutlook.CreateItem(0)
Set rngeData = Worksheets("Promo Sync").Range("A5:Y86")
'Copy Range
rngeData.CopyPicture Appearance:=xlScreen, Format:=xlPicture
Dim wordDoc As Word.Document
Set wordDoc = aEmail.GetInspector.WordEditor
'Paste picture
aEmail.Display
wordDoc.Range.Paste
Set rngeAddresses = ActiveSheet.Range("AK2:AK23")
For Each rngeCell In rngeAddresses.Cells
strRecipients = strRecipients & ";" & rngeCell.Value
Next
'Set Subject
aEmail.Subject = "Promo Sync " & Now()
'Set Recipient
aEmail.To = strRecipients
'Send Mail
aEmail.Send
End Sub
Try rngeData.Copy Then wordDoc.Range.PasteAndFormat wdPasteEnhancedMetafile
This should give you good quality wdPasteDataType, similar to Ctrl+V
WdPasteDataType Enumeration (Word)
Related
I created code to copy a cell range into an email.
A) This gets me an image where the text is blurry and overly bold
.PasteandFormat wdChartPicture
B) This gets me the correct text clarity but I need to zoom the email itself to x300 to visualize the numbers and letters clearly
.PasteandFormat wdMatchDestinationFormatting
How can I paste in a size that is clear to visualize?
Alternatively how can I increase the pasted image so that the recipient doesn't have to zoom x300 to see the email?
Option Explicit
Sub Send_Email()
Dim OutApp As Object
Dim OutMail As Object
Dim table As Range
Dim pic As Picture
Dim wb As Workbook, ws As Worksheet, wsSettings As Worksheet
Dim wordDoc
Dim strHTMLBody As String
Dim lonZoom As Long
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Set wb = ThisWorkbook
Set wsSettings = wb.Worksheets("Settings")
'grab table, convert to image, and cut'
Set ws = ThisWorkbook.Sheets("Summary")
Set table = ws.Range("B8:AA338")
ws.Activate
table.Copy
Set pic = ws.Pictures.Paste
pic.Cut
'create email message'
On Error Resume Next
With OutMail
strHTMLBody = strHTMLBody & "</span>"
.HTMLBody = strHTMLBody
.To = wsSettings.Range("Email_To").Value
.Subject = wsSettings.Range("Email_Subject").Value
.Display
Set wordDoc = OutMail.GetInspector.WordEditor
With wordDoc.Range
.PasteandFormat wdMatchDestinationFormatting
End With
End With
On Error GoTo 0
Set OutApp = Nothing
Set OutMail = Nothing
End Sub
You deal with a message body which is an HTML markup. So, you can save the generated image in Excel as a file and then attach it to the mail item and use in the body markup in the way you like.
The Attachments.Add method allows to attach a file. But you need to use an embedded image (not visible attachments). You need to set up the CID property on the attachment and use the CID attribute in the HTML markup.
Refer to the image in the HTML body through the cid attribute
<img src="cid:xyz">
Then add the attachment using Attachments.Add.
After that you can set the PR_ATTACH_CONTENT_ID property (DASL name http://schemas.microsoft.com/mapi/proptag/0x3712001F) using Attachment.PropertyAccessor.SetProperty. This will be your cid value.
So I have this code that will capture a range in excel and export it and then embed it into the body of an email, along with a bunch of text however the image is appearing white/blank unless I have the worksheet open in front (I have tried adding code to maximize the window and this doesn't work).
it only seems to work when I run it one line at a time. was hoping someone could help me as I am lost
I am not very good at vba only a small bit of self-teaching so it may be a little ugly looking, sorry I will try to explain more if necessary.
Public reportInterval As String
Public startBody As String
Public digitalBody As String
Public socroBody As String
Public fleetBody As String
Public loopBody As String
Public morningOrDay As String
Public picFile As String
Public picBody As String
Sub emailPic()
'===================================================
' Export Range as PNG file
'===================================================
' Set Range you want to export to file
Dim r As Range
Dim co As ChartObject
Workbooks(controlWS).Sheets(tempWS).Select
Set r = Range("A1:R133")
' Copy range as picture onto Clipboard
r.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
picFile = Environ("Temp") & "\TempExportChart.png"
' Create an empty chart with exact size of range copied
Set co = r.Parent.ChartObjects.Add(Left:=r.Left, Top:=r.Top, Width:=r.Width, Height:=r.Height)
With co
' Paste into chart area, export to file, delete chart.
.Chart.Paste
.Chart.Export picFile
.Delete
End With
End Sub
Sub sendMail()
On Error GoTo ErrHandler
Dim objOutlook As Object
Set objOutlook = CreateObject("Outlook.Application")
Dim objEmail As Object
Set objEmail = objOutlook.CreateItem(olMailItem)
reportInterval = ""
Call emailPic
Call intervalFinder
Call morningOrDayFinder
Call htmlEmailBody
picBody = "<img src=""" & picFile & """ style=""width:304px;height:228px"">"
With objEmail
.Display
.SentOnBehalfOfName =
.To =
.CC =
.Recipients.ResolveAll
.Subject = "Intraday Report: " & reportInterval
.HTMLBody = HTMLBody & startBody & digitalBody & socroBody & fleetBody & loopBody _
& picBody
End With
Set objEmail = Nothing: Set objOutlook = Nothing
ErrHandler:
'
End Sub
The issue is the picture file is being created as blank via the chart object. I have previously found issues using chart objects to save pictures adding borders where I don't want them so I use publishers functions instead to save pictures. This does require a reference to be added.
Updated function to save the picture (you will need to re-edit back to the sheet you want to export)
Sub emailPic()
' Requires reference: Microsoft Publisher x.x Object Library
'===================================================
' Export Range as PNG file
'===================================================
Dim r As Range
Dim picFile As String: picFile = Environ("Temp") & "\TempExport.png"
If Dir(picFile) <> "" Then Kill picFile
With ThisWorkbook.Sheets("Sheet1")
Set r = .Range("A1:R133")
r.CopyPicture Appearance:=xlScreen, Format:=xlBitmap ' Copy range as picture onto Clipboard
End With
Dim PubDoc As New Publisher.Document
PubDoc.Pages(1).Shapes.Paste
PubDoc.Pages(1).Shapes(1).SaveAsPicture _
PbResolution:=pbPictureResolutionCommercialPrint_300dpi, _
Filename:=picFile
PubDoc.Close
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
This is the code in outlook VBA
Sub Sendmail()
Dim olItem As Outlook.MailItem
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSht As Excel.Worksheet
Dim sPath As String
Dim iRow As Long
Dim strRFIitems As String
Dim Signature As String
sPath = "**"
' // Excel
Set xlApp = CreateObject("Excel.Application")
' // Workbook
Set xlBook = xlApp.Workbooks.Open(sPath)
' // Sheet
Set xlSht = xlBook.Sheets("Sheet1")
' // Create e-mail Item
Set olItem = Application.CreateItem(olMailItem)
strRFIitems = xlSht.Range("E2")
Signature = xlSht.Range("F2")
With olItem
.To = Join(xlApp.Transpose(xlSht.Range("A2", xlSht.Range("A9999").End(xlUp))), ";")
.CC = Join(xlApp.Transpose(xlSht.Range("B2", xlSht.Range("B9999").End(xlUp))), ";")
.Subject = xlSht.Range("C2")
.Body = xlSht.Range("D2") & Signature
.Attachments.Add (strRFIitems)
.Display
End With
' // Close
xlBook.Close SaveChanges:=True
' // Quit
xlApp.Quit
Set xlApp = Nothing
Set xlBook = Nothing
Set xlSht = Nothing
Set olItem = Nothing
End Sub
The code retrieves the data from the linked Excel sheet. Now the
problem is with .Body = xlSht.Range("D2") & Signature this line
of code, where the body of the mail is retrieved from the D2 cell of
Excel sheet.
And as per my requirement, the body of the mail should contain a hyper
link and table along with the text.
Example:
Hello All,
Please update the details in the portal
portal link :http://google.com.
Please contact me for any clarifications.
Below mentioned details needs to be updated:
table has to be inserted here
Suppose above mentioned text is inserted into a cell of Excel.
List item
This portal link: http://google.com. becomes a plain text not a hyper link.
If I try to make it a hyper link the entire cell becomes hyper link. i.e even the text.
List item
How to insert table into a cell of Excel sheet and call it using Outlook VBA
Query:
How to insert a hyperlink and table along with the test
message into a cell of Excel and retrieve it as it is using the above
mentioned code and send a mail containing hyperlink and table.
For hyperlink you can use the following code:
Range("K6").Select
ActiveCell.FormulaR1C1 = "test"
Range("K6").Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:= _
"http://www.google.com", TextToDisplay:="test"
Range("K6").Select
Selection.Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True
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