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
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.
The VBA code below sends email with a specific range in body.
Despite selecting only visible cells, I receive all cells.
It seems SpecialCells(xlCellTypeVisible).Select does not work.
Sub VBA_AUTO_MAIL()
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("Arkusz1")
Dim lr As Integer
lr = sh.Range("A" & Application.Rows.Count).End(xlUp).Row
sh.Range("A1:H" & lr).SpecialCells(xlCellTypeVisible).Select
ThisWorkbook.EnvelopeVisible = True
With Selection.Parent.MailEnvelope.Item
.to = sh.Range("L6").Value
.cc = sh.Range("L8").Value
.Subject = sh.Range("L9").Value
.attachments.Add "C:\Users\test\Desktop\TEST VBA\TEST_VBA.txt"
.send
End With
End Sub
I expect only visible columns in email body but I receive all columns.
Try the following
Option Explicit
Sub VBA_AUTO_MAIL()
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("Arkusz1")
Dim lr As Long
lr = sh.Range("A" & Application.Rows.Count).End(xlUp).Row
Dim rng As Range
Set rng = sh.Range("A1:H" & lr).SpecialCells(xlCellTypeVisible)
rng.Copy
Dim olApp As Object
Set olApp = CreateObject("Outlook.Application")
Dim Email As Object
Set Email = olApp.CreateItem(0)
Dim wdDoc As Word.Document
Set wdDoc = Email.GetInspector.WordEditor
With Email
.To = sh.Range("L6").Value
.CC = sh.Range("L8").Value
.BCC = ""
.Subject = sh.Range("L9").Value
'.Attachments.Add "C:\Users\test\Desktop\TEST VBA\TEST_VBA.txt"
.Display
wdDoc.Range.PasteAndFormat Type:=wdChartPicture
.Send
End With
End Sub
Make sure to Reference Microsoft Word xx.x Object Library
https://stackoverflow.com/a/42662697/4539709
I already made this code, I want to send a image already exist inside the Excel (called Picture 1810) by e-mail. But I cant discovery how to do the .Body.
Anyone can help me?
Sub CreateMail()
Dim objOutlook As Object
Dim objMail As Object
Dim rngTo As Range
Dim rngCC As Range
Dim rngSubject As Range
Dim rngBody As Shape
Dim rngAttach As Range
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
With ActiveSheet
Set rngTo = .Range("f2")
Set rngCC = .Range("f3")
Set rngSubject = .Range("c2")
Set rngBody = .Shapes("Picture 1810")
End With
With objMail
.To = rngTo.Value
.CC = rngCC.Value
.Subject = rngSubject.Value
.Body = rnbbody
.Send
End With
Set objOutlook = Nothing
Set objMail = Nothing
Set rngTo = Nothing
Set rngSubject = Nothing
Set rngBody = Nothing
Set rngAttach = Nothing
End Sub
By this you retain your standard email signature and paste the shape either floating over the body text or like a character in between:
With objMail
.To = rngTo.Value
.CC = rngCC.Value
.Subject = rngSubject.Value
.Display
Dim wdDoc As Word.Document
Set wdDoc = .GetInspector.WordEditor
If Not wdDoc Is Nothing Then
With wdDoc.Range
.Collapse wdCollapseStart
.InsertBefore "Hi there," & vbCrLf & "here's my shape:" & vbCrLf
.Collapse wdCollapseEnd
.InsertAfter vbCrLf & "Best wishes," & vbCrLf
.Collapse wdCollapseStart
ActiveSheet.Shapes("Picture 1810").Copy
'.Paste ' over the text
.PasteAndFormat wdChartPicture ' within text
End With
Set wdDoc = Nothing
End If
'.Send
End With
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'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