I'm trying to copy a range in Excel as a picture to Outlook mail and add text in the body as well.
My code is adding the text and then pasting the picture on top of it. How can I get it to paste under the text?
Dim OutApp As Object
Dim outMail As Object
Dim myFileList(1) As String
Dim i As Long
Set OutApp = CreateObject("Outlook.Application")
Set outMail = OutApp.CreateItem(0)
Set RngCopied = Worksheets("Daily volume summary").Range("VolumeRange")
myFileList(0) = "Y:xyz\sales.pdf"
myFileList(1) = "Y:xyz\sales.xlsx"
'On Error Resume Next
With outMail
.To = "abc#xyz.com"
.CC = "def#xyz.com"
.BCC = ""
.Subject = "PBC Daily Sales " & Format(Date, "mm/dd/yyyy")
.Body = "Good morning," & vbNewLine & vbNewLine & "Attach is the Daily Sales report for " & Format(Date, "dddd,mmmm,dd,YYYY") & "." & "<br>"
'Copy range of interest
Dim r As Range
Set r = Worksheets("Daily volume summary").Range("VolumeRange")
r.Copy
'Get its Word editor
outMail.Display
Dim wordDoc As Word.Document
Set wordDoc = outMail.GetInspector.WordEditor
'To paste as picture
wordDoc.Range.PasteAndFormat wdChartPicture
Dim shp As Object
For Each shp In wordDoc.InlineShapes
shp.ScaleHeight = 60
shp.ScaleWidth = 60
Next
For i = 0 To UBound(myFileList)
.Attachments.Add myFileList(i)
Next
.Send
End With
On Error GoTo 0
Set outMail = Nothing
Set OutApp = Nothing
End Sub
In the line:
wordDoc.Range.PasteAndFormat wdChartPicture
you are replacing the ENTIRE range of the message's word doc with your picture. Instead you need to note where in the range you want to paste this. This should put it after your text:
wordDoc.Range(start:=wordDoc.Range.End - 2).PasteAndFormat wdChartPicture
Related
I found macros to send an email to each person in a column.
Column B shows the names which have "Yes" in column C. I have added this condition in Power Query.
Sub Send_Row_Or_Rows_Attachment_1()
'Working in 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Dim intHowManyRows As Integer
With Application
.ScreenUpdating = False
End With
intHowManyRows = Application.Range("B2").CurrentRegion.Rows.Count
For r = 1 To intHowManyRows
'Save, Mail, Close and Delete the file
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = ThisWorkbook.Sheets("Sheet3").Range("B1").Value
' Cells(r, 2).Value
.Subject = Cells(r, 3).Value
'.Attachments.Add FullName -> If you want to add attachments
.Body = "Hi there" & vbNewLine & vbNewLine & "How are you " & Cells(r, 2)
.Display 'Or use Send
End With
Next r
Set OutMail = Nothing
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
Or:
Sub Test2()
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'Working in Office 2000-2016
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
On Error GoTo cleanup
For Each cell In Columns("B").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*#?*.?*" And _
LCase(Cells(cell.Row, "C").Value) = "yes" Then
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = ThisWorkbook.Sheets("Sheet3").Range("B1").Value
.Subject = "Reminder"
.Body = "Dear " & Cells(cell.Row, "A").Value _
& vbNewLine & vbNewLine & _
"Please contact us to discuss bringing " & _
"your account up to date"
'You can add files also like this
'.Attachments.Add ("C:\test.txt")
.Send 'Or use Display
End With
On Error GoTo 0
Set OutMail = Nothing
End If
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
I want to generate a single Outlook mail with all persons in column B in the "To" and also attach a file.
I adjusted Ron's code. See my comments and adjust it to fit your needs.
EDIT: As per niton's suggestion, remove the on error resume next and see what line causes the error.
Option Explicit
Public Sub SendEmail()
' For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
' Working in Office 2000-2016
' Adapted by Ricardo Diaz ricardodiaz.co
Dim OutApp As Object
Dim OutMail As Object
Dim sourceTable As ListObject
Dim evalRow As ListRow
Dim counter As Long
Dim toArray() As Variant
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
Set sourceTable = Range("Table1").ListObject ' -> Set the table's name
On Error GoTo cleanup
' Loop through each table's rows
For Each evalRow In sourceTable.ListRows
If evalRow.Range.Cells(, 2).Value Like "?*#?*.?*" And LCase(evalRow.Range.Cells(, 3).Value) = "yes" Then
ReDim Preserve toArray(counter)
toArray(counter) = evalRow.Range.Cells(, 2).Value
counter = counter + 1
End If
Next evalRow
' Setup the email
Set OutMail = OutApp.CreateItem(0)
With OutMail
' Add gathered recipients
For counter = 0 To UBound(toArray)
.Recipients.Add (toArray(counter))
Next counter
.Subject = "Reminder"
.Body = "Dear All" _
& vbNewLine & vbNewLine & _
"Please contact us to discuss bringing " & _
"your account up to date"
'You can add files also like this
.Attachments.Add ("C:\test.txt") ' -> Adjust this path
.Send ' -> Or use Display
End With
Set OutMail = Nothing
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
Let me know if it works.
Would anyone be so kind and help me out with my problem? I have this example table:
I would like to send a personalized email for each row, this is what I got so far:
Sub SendEmails()
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
On Error GoTo cleanup
For Each cell In Columns("A").Cells.SpecialCells(xlCellTypeConstants)
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = cell.Value
.Subject = "Project" & Sheets("Sheet1").Range("C").Value ' insert subject from column C
.HTMLBody = "<p>Hello " & Sheets("Sheet1").Range("B").Value &"</p>" & _ ' insert Name from column B
"<p><strong><u>This is a test email</u></strong></p>"
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
I would like to have data from columns B and C in the email, but I have no idea how to reference them in For each loop and how to put them to the place I want.
Thank you
Try this code : (I changed 3 lines in your code, I marked Them with (X))
Sub SendEmails()
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
On Error GoTo cleanup
For Each cell In Columns("A").Cells.SpecialCells(xlCellTypeConstants)
i = cell.Row '(X)
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = cell.Value
.Subject = "Project" & Sheets("Sheet1").Range("C" & i).Value '(X)
.HTMLBody = "<p>Hello " & Sheets("Sheet1").Range("B" & i).Value & "</p>" & "<p><strong><u>This is a test email</u></strong></p>" '(X)
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
Instead if using a Range Object you store the content of the Range you are using into a matrix (2D Array)
Now you can access the "cells" by indexing your array. So content of column B would be myArray(rowNumber,2)
Sub SendEmails()
Dim OutApp As Object
Dim OutMail As Object
Dim rng As Variant
myArray= ThisWorkbook.Sheets("Sheet1").Range("A1:C4")
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
For i = 2 To UBound(myArray)
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = myArray(i, 1)
.Subject = "Project" & myArray(i, 3)
.HTMLBody = "<p>Hello " & myArray(i, 2) & "</p>" & _
"<p><strong><u>This is a test email</u></strong></p>"
.Display
End With
Next i
Try it like this.
In column A : Names of the people
In column B : E-mail addresses
In column C:Z : Filenames like this C:\Data\Book2.xls (don't have to be Excel files)
The Macro will loop through each row in "Sheet1" and if there is a E-mail address in column B
and file name(s) in column C:Z it will create a mail with this information and send it.
Sub Send_Files()
'Working in Excel 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
Dim rng 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)
'Enter the path/file names in the C:Z column in each row
Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")
If cell.Value Like "?*#?*.?*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = cell.Value
.Subject = "Testfile"
.Body = "Hi " & cell.Offset(0, -1).Value
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 'Or use .Display
End With
Set OutMail = Nothing
End If
Next cell
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
https://www.rondebruin.nl/win/s1/outlook/amail6.htm
Tried all other codes on similar pages but failed to work.
This is my current version. Works only if I currently have a new email window open and oddly, my code will paste the .body and cell range details into 2 separate new email windows.
I just want the code to open a new email window with contents .body and cell range details (contains chart). Anybody have any ideas where my code went wrong?
Sub pasting01()
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.TO = "xyz#anc.com"
.CC = "abc#xyz.com"
.Subject = "Test"
.Body = "Dear Mr Lee" & vbNewLine
ActiveSheet.Range("A1:J30").Copy
Set vInspector = OutMail.GetInspector
Set wEditor = vInspector.WordEditor
wEditor.Application.Selection.Start = Len(.Body)
wEditor.Application.Selection.End = wEditor.Application.Selection.Start
wEditor.Application.Selection.Paste
.display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
You have some errors on your code, try using Option Explicit top of your module
Option Explicit
Public Sub pasting01()
Dim Sht As Excel.Worksheet
Set Sht = ThisWorkbook.ActiveSheet
Dim rng As Range
Set rng = Sht.Range("A1:J30")
rng.Copy
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
With OutMail
.TO = "xyz#anc.com"
.CC = "abc#xyz.com"
.Subject = "Test"
.display
wEditor.Paragraphs(1).Range.Text = "Dear Mr Lee" & vbCr
wEditor.Paragraphs(2).Range.Paste
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Can you mess about with the following to suit your purpose?
Option Explicit
Sub pasting01()
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Dim myChart As Chart
Set myChart = ThisWorkbook.Worksheets("Sheet1").ChartObjects("Chart 1").Chart
Dim myPicture As String
Dim fileName As String
Dim myPath As String
myPicture = "Chart1.png"
myPath = "C:\Users\User\Desktop\"
fileName = myPath & myPicture
myChart.Export fileName
With OutMail
.TO = "xyz#anc.com"
.CC = "abc#xyz.com"
.Subject = "Test"
.Body = "Dear Mr Lee" & vbNewLine
.Attachments.Add fileName
.HTMLBody = "<html><p>First Line... </p>" & _
"<img src=cid:" & Replace(myPicture, " ", "%20") & " height=2*240 width=2*180>" & _
"<p>Salutation</p>" & _
"<p>" & "More text" & "</p></html>"
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
Kill fileName
End Sub
Result:
I would like to copy a range from protected Excel sheet and paste it into Outlook as a picture.
My code is pasting the text then the picture, but at the same time deleting the text.
How can I paste the picture under the text.
Sub Send_Email()
Dim r As Range
Set r = Range("NR7:OD39")
Dim outlookApp As Outlook.Application
Set outlookApp = CreateObject("Outlook.Application")
Dim OutMail As Outlook.MailItem
Set OutMail = outlookApp.CreateItem(olMailItem)
Dim StrFileName As String
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Sheets("table1").Select
ActiveSheet.Unprotect Password:="blabla"
ActiveSheet.Outline.ShowLevels RowLevels:=8, ColumnLevels:=8
r.Select
r.Copy
OutMail.Display
Dim Email As Word.Document
Set Email = OutMail.GetInspector.WordEditor
With OutMail
.To = "Name.surname#amazon.com"
.CC = "Surname.Name#amazon.com"
.Subject = "Subject"
.Body = "Hi everybody," & vbNewLine & "actual Status"
.Display
End With
Email.Range.PasteAndFormat wdChartPicture
ActiveSheet.Outline.ShowLevels RowLevels:=1, ColumnLevels:=1
ActiveSheet.Protect Password:="blabla"
End Sub
Starting with this line
Set Email = OutMail.GetInspector.WordEditor
this should do it:
Dim ran as Word.Range
Set Email = OutMail.GetInspector.WordEditor
With OutMail
.To = "Name.surname#amazon.com"
.cc = "Surname.Name#amazon.com"
.Subject = "Subject"
.Body = "Hi everybody," & vbNewLine & "actual Status"
.Display
End With
Email.Range.InsertAfter vbCrLf
Set ran = Email.Range(Email.Content.End - 1, Email.Content.End - 1)
ran.PasteAndFormat wdChartPicture
This question already has an answer here:
Excel 2010 Paste Range and Picture into Outlook
(1 answer)
Closed 7 years ago.
Pretty simple and straight forward. I am looking to copy a range in a worksheet, open a new email to outlook and paste the range as an image. The following code is what I currently have. Despite my efforts, I have been unable to paste as a photo.
Sub CreateMail()
Dim objOutlook As Object
Dim objMail As Object
Dim rngTo As Range
Dim rngBody As Range
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
With Sheets("Hourly Labor Model")
Set rngBody = .Range(.Range("A6"), .Range("AA99").End(xlDown))
End With
rngBody.Copy
With objMail
.To = "user#useremail.com"
.Subject = "Hourly Dashboard- " & Sheets("Graphs").Range("AA1") & " on " & Format(Now(), "mm/dd/yyyy") & " # " & Format(Time(), "hh:mm:ss")
.display
End With
SendKeys "^({v})", True
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Please and thank you in advance.
Based on this thread, I think the below would work:
Sub CreateMail()
Dim objOutlook As Object
Dim objMail As Object
Dim rngTo As Range
Dim rngBody As Range
Dim outMail As Outlook.MailItem 'new
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
Set outMail = objOutlook.CreateItem(olMailItem)
With Sheets("Hourly Labor Model")
Set rngBody = .Range(.Range("A6"), .Range("AA99").End(xlDown))
End With
rngBody.Copy
With objMail
.To = "user#useremail.com"
.Subject = "Hourly Dashboard- " & Sheets("Graphs").Range("AA1") & " on " & Format(Now(), "mm/dd/yyyy") & " # " & Format(Time(), "hh:mm:ss")
.Display
'outMail.Display
Dim wordDoc As Word.Document
Set wordDoc = .GetInspector.WordEditor ' or use outMail instead of with()
wordDoc.Range.PasteandFormat wdChartPicture
End With
SendKeys "^({v})", True
On Error GoTo 0
Set outMail = Nothing
Set OutApp = Nothing
End Sub