I have found the code below from here https://stackoverflow.com/a/49207287/4539709
Option Explicit
Public Sub Example()
' add ref - tool -> references - > Microsoft Outlook XX.X Object Library
Dim olApp As Outlook.Application
Set olApp = New Outlook.Application
Dim Email As Outlook.MailItem
Set Email = olApp.CreateItem(0)
' add ref - tool -> references - > Microsoft Word XX.X Object Library
Dim wdDoc As Word.Document '<=========
Set wdDoc = Email.GetInspector.WordEditor
Dim Sht As Excel.Worksheet
Set Sht = ThisWorkbook.Worksheets("Sheet1")
Dim rng As Range
Set rng = Sht.Range("A4:H16").SpecialCells(xlCellTypeVisible)
rng.Copy
With Email
.To = Sht.Range("C1")
.Subject = Sht.Range("B1")
.Display
wdDoc.Range.PasteAndFormat Type:=wdFormatOriginalFormatting
End With
End Sub
I have come across an issue with the code in that after you send an email the rows remain selected as per attached. Is there anyway to clear this
Add the following line at the end Application.CutCopyMode = False
With Email
.To = Sht.Range("C1")
.Subject = Sht.Range("B1")
.Display
wdDoc.Range.PasteAndFormat Type:=wdFormatOriginalFormatting
End With
Application.CutCopyMode = False '<---
End Sub
Related
I have a code in Excel that copy a table to a new Email:
Option Explicit
Public Sub TESTEMAIL()
Const olMailItem As Long = 0
Dim StrFile, signature As String
Dim OutApp As Outlook.Application
Dim Outmail As Outlook.MailItem
Set OutApp = CreateObject("Outlook.Application")
Set Outmail = OutApp.CreateItem(olMailItem)
Dim myRecipient As Object
Set OutApp = CreateObject("Outlook.Application")
Set Outmail = OutApp.CreateItem(olMailItem)
Set OutApp = Nothing
Outmail.Display
Dim wordDoc As Word.Document
Set wordDoc = Outmail.GetInspector.WordEditor
Range("A1:E10").Copy
Dim p1 As Picture
Set p1 = ActiveSheet.Pictures.Paste
p1.Cut
With wordDoc.Application.Selection
.Start = Len(Outmail.Body) ' error n° 91
.End = .Start
.PasteSpecial wdPasteBitmap ' Error n° 4605 or Error n°91
End With
End Sub
The code returns an error every first time I use it after starting the computer:
Error Code 91 "Object variable or With block variable not set"
It is most of the time when Outlook wasn't opened before or when no new email was opened before.
Sometimes I also get the error code 4605, saying that the document is locked against modifications.
The 2 Errors are coming at the end and are marked in the code. (error can happen on 2 different lines)
Sometimes everything worked but only when a new email was opened in Outlook before, (event if Outlook is closed).
Any clue why that might be and how to solve the problem?
Is this what you are trying to do?
Example
Option Explicit
Public Sub TESTEMAIL()
Dim OutApp As Outlook.Application
Set OutApp = CreateObject("Outlook.Application")
Dim Outmail As Outlook.MailItem
Set Outmail = OutApp.CreateItem(olMailItem)
Dim wordDoc As Word.Document
Set wordDoc = Outmail.GetInspector.WordEditor
Dim Sht As Excel.Worksheet
Set Sht = ActiveWorkbook.Sheets("Sheet1")
Dim rng As Range
Set rng = Sht.Range("A1:E10")
rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
With Outmail
.To = "0m3r#email.com"
.CC = ""
.BCC = ""
.Subject = "Hello"
.Display
wordDoc.Paragraphs(1).Range.PasteSpecial Link:=False, _
DataType:=wdPasteBitmap, _
Placement:=wdFloatOverText, _
DisplayAsIcon:=False
wordDoc.Paragraphs(1).SpaceAfter = 20 ' add space to 12 points
wordDoc.Range.InsertBefore "Hello 0m3r" & vbCr
wordDoc.Paragraphs(1).SpaceAfter = 20 ' add space to 12 points
End With
End Sub
Make sure to Reference to Microsoft Word & Outlook xx.x Object Library
MSDN Paragraphs.SpaceAfter property (Word)
MSDN Range.PasteAndFormat method (Word)
MSDN PasteAndFormat Method
MSDN WdPasteDataType enumeration (Word)
I am trying to paste multiple Excel ranges as images in Outlook mail using VBA. I am using the answer to this question (Pasting an Excel range into an email as a picture) to paste a range of excel as image in mail but as soon as I paste another range, it overwrites the previous image. Is there anyway to change the cursor position in Outlook mail using wordeditor. I tried using collapse before pasting the image but it did not help. Also how do I add the text to it as using Outmail.body to edit anything gets overwritten too by the image pasted afterwards.
This is the code I am using:
Sub Sendmail()
Dim r as range
Set r = Range("C2:O13)
r.copy
dim outlookapp as Outlook.Application
set outlookapp = CreateObject("Outlook.Application")
dim outMail As Outlook.Mailitem
Set outMail = outlookApp.CreateItem(olMailItem)
With outMail
.Display
.CC = "xyz#abc.com"
.Subject = "Test"
.Body = "Dear" & "Macro" & vbnewline
end with
outmail.Display
'Opening wordeditor
dim worddoc as Word.Document
Set worddoc = Outmail.GetInspector.WordEditor
worddoc.range.PasteandFormat wdChartPicture
'Adding new line after pasting image
worddoc.range.Insertafter vbNewline
' Adding second image
dim s as range
set s= Range(P2:Z30)
s.copy
worddoc.range.PasteandFormat wdChartPicture
You could refer to the below code:
Option Explicit
Public Sub Example()
Dim rng As Range
Dim olApp As Object
Dim Email As Object
Dim Sht As Excel.Worksheet
Dim wdDoc As Word.Document
Set Sht = ActiveWorkbook.Sheets("Dashboard")
Set rng = Sht.Range("B4:L17")
rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set olApp = CreateObject("Outlook.Application")
Set Email = olApp.CreateItem(0)
Set wdDoc = Email.GetInspector.WordEditor
With Email
.To = ""
.CC = ""
.BCC = ""
.Subject = ""
.Attachments.Add ActiveWorkbook.FullName
wdDoc.Range.PasteAndFormat Type:=wdChartPicture
' if need setup inlineshapes hight & width
With wdDoc
.InlineShapes(1).Height = 130
End With
.Display
End With
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set Email = Nothing
Set olApp = Nothing
End Sub
For more information, please refer to these links:
Copy Excel range as Picture to Outlook
Copy range of cells from Excel as picture and add text in the email body
I have an Excel file where when the user presses a button:
A range is selected and copied to the clipboard
An Outlook message is created based on a template
E-mail will be sent "on behalf of" instead of the user's name/account
The user adds a date in the e-mail and pastes the copied range into the template.
This is all working but Outlook adds the user's signature and that is unwanted.
Sub SelectArea()
Application.ScreenUpdating = False
lastCol = ActiveSheet.Range("a1").End(xlToRight).Column - 2
lastRow = ActiveSheet.Cells(500, lastCol).End(xlUp).Row
ActiveSheet.Range("a1", ActiveSheet.Cells(lastRow, lastCol)).Copy
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItemFromTemplate("\\network\path\to\the\MailTemplate.oft")
With OutMail
.SentOnBehalfOfName = """DepartmentX"" <DepartmentX#company.com>"
.Display
End With
Application.ScreenUpdating = True
End Sub
Currently there is no DeleteSig sub. It used to be inside With OutMail. I tested the example from the Microsoft site 1:1 but could not get it to work.
The code from Microsoft:
Sub TestDeleteSig()
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem
Set objOL = CreateObject("Outlook.Application")
Set objMsg = objOL.CreateItem(olMailItem)
objMsg.Display
Call DeleteSig(objMsg)
Set objMsg = Nothing
End Sub
Sub DeleteSig(msg As Outlook.MailItem)
Dim objDoc As Word.Document
Dim objBkm As Word.Bookmark
On Error Resume Next
Set objDoc = msg.GetInspector.WordEditor
Set objBkm = objDoc.Bookmarks("_MailAutoSig")
If Not objBkm Is Nothing Then
objBkm.Select
objDoc.Windows(1).Selection.Delete
End If
Set objDoc = Nothing
Set objBkm = Nothing
End Sub
It opens a new e-mail message with signature and gives a compile error.
"User-defined type not defined".
It marks Sub DeleteSig(msg As Outlook.MailItem) in yellow and highlights objDoc As Word.Document in blue.
This will remove the signature from an email template
The last Sub will place a selected range from Excel into the body of the template
Option Explicit
Public Sub TestDeleteSig()
Dim olApp As Object, olMsg As Object
Set olApp = CreateObject("Outlook.Application")
Set olMsg = olApp.CreateItem(0)
olMsg.Display
DeleteSig olMsg
InsertRng olMsg
Set olMsg = Nothing
End Sub
Private Sub DeleteSig(msg As Object)
Dim wrdDoc As Object, wrdBkm As Object
On Error Resume Next
Set wrdDoc = msg.GetInspector.WordEditor
Set wrdBkm = wrdDoc.Bookmarks("_MailAutoSig")
If Not wrdBkm Is Nothing Then wrdBkm.Range.Delete
Set wrdDoc = Nothing
Set wrdBkm = Nothing
End Sub
Private Sub InsertRng(msg As Object)
Dim rng As Range
Set rng = Selection.SpecialCells(xlCellTypeVisible)
If Not rng Is Nothing Then
If rng.Rows.Count = 1 And rng.Columns.Count = 1 Then
If Len(rng) = 0 Then Set rng = ActiveSheet.UsedRange.Cells(1)
End If
rng.Copy
msg.GetInspector.WordEditor.Content.PasteSpecial xlPasteAll
Application.CutCopyMode = False
End If
End Sub
If only one cell is selected and is empty, it will paste the first cell with data from ActiveSheet
So, this is the VBA code that is currently running.
It selects the range, copies it to a blank e-mail, pastes it there and deletes the users' signature.
The "problem" is that it should open a new e-mail based on an existing template (.oft) and paste it where it reads "<insert table/overview>". The oft has an image header and some (html/formatted) text in it.
I'm startin to wonder if what I'm trying to accomplish is even possible.
Sub DeleteSig()
Dim olApp As Object, olMsg As Object
Set olApp = CreateObject("Outlook.Application")
Set olMsg = olApp.CreateItemFromTemplate("\\myserver\my_template.oft")
olMsg.Display
DeleteSig_action olMsg
InsertRng olMsg
Set olMsg = Nothing
End Sub
Sub DeleteSig_action(msg As Object)
Dim wrdDoc As Object, wrdBkm As Object
On Error Resume Next
Set wrdDoc = msg.GetInspector.WordEditor
Set wrdBkm = wrdDoc.Bookmarks("_MailAutoSig")
If Not wrdBkm Is Nothing Then wrdBkm.Range.Delete
Set wrdDoc = Nothing
Set wrdBkm = Nothing
End Sub
Sub InsertRng(msg As Object)
Dim rng As Range
lastCol = ActiveSheet.Range("a1").End(xlToRight).Column - 2
lastRow = ActiveSheet.Cells(500, lastCol).End(xlUp).Row
Set rng = ActiveSheet.Range("a1", ActiveSheet.Cells(lastRow, lastCol))
rng.Copy
msg.GetInspector.WordEditor.Content.PasteSpecial xlPasteAll
Application.CutCopyMode = False
End Sub
Hers is the complete working code which removes signature from the mail template.
Option Explicit
Sub openEmail()
Dim cfgFromEmail As String
Dim cfgNotice As String
Dim cfgTemplate As String
Dim appOutlook As Outlook.Application
Dim newEmail As Outlook.MailItem
Dim rownum As Integer
Dim colnum As Integer
rownum = 6
cfgFromEmail = Sheets("Email").Range("O5").Value
cfgNotice = Sheets("Email").Cells(rownum, 10) '10 = column J
cfgTemplate = Sheets("Email").Cells(rownum, 11) '11 = column K
Set appOutlook = CreateObject("Outlook.Application")
Set newEmail = appOutlook.CreateItemFromTemplate(ThisWorkbook.Path & "\" & cfgTemplate & ".oft")
'Set template = mailApp.CreateItem(olMailItem) 'Creates a blank email
If cfgNotice <> "null" Then 'If is not blank
MsgBox cfgNotice, vbInformation, "Before you send the email"
End If
Dim objDoc As Word.Document
Dim objBkm As Word.Bookmark
On Error Resume Next
Set objDoc = newEmail.GetInspector.WordEditor
Set objBkm = objDoc.Bookmarks("_MailAutoSig")
If Not objBkm Is Nothing Then
objBkm.Select
objDoc.Windows(1).Selection.Delete
End If
Set objDoc = Nothing
Set objBkm = Nothing
With newEmail
.SentOnBehalfOfName = cfgFromEmail
.Display 'Show the email
End With
Set newEmail = Nothing
Set appOutlook = Nothing
End Sub
I'm creating an Outlook email from Excel (Office 2013). I want to paste a range of cells (C3:S52) into the email as a picture.
Below is the code I have so far. Where am I going wrong?
Sub Button193_Click()
'
' Button193_Click Macro
'
'
ActiveWindow.ScrollColumn = 2
ActiveWindow.ScrollColumn = 1
Range("C3:S52").Select
Selection.Copy
End Sub
Sub CreateMail()
Dim objOutlook As Object
Dim objMail As Object
Dim rngTo As Range
Dim rngSubject As Range
Dim rngBody As Range
Dim rngAttach As Range
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
With ActiveSheet
Set rngTo = .Range("E55")
Set rngSubject = .Range("E56")
Set rngBody = .Range("E57")
End With
With objMail
.To = rngTo.Value
.Subject = rngSubject.Value
.Body = rngBody.Value
.Display 'Instead of .Display, you can use .Send to send the email _
or .Save to save a copy in the drafts folder
End With
Set objOutlook = Nothing
Set objMail = Nothing
Set rngTo = Nothing
Set rngSubject = Nothing
Set rngBody = Nothing
Set rngAttach = Nothing
End Sub
Sub Button235_Click()
'
' Button235_Click Macro
'
'
ActiveWindow.ScrollColumn = 2
ActiveWindow.ScrollColumn = 1
Range("A1:M27").Select
Selection.Copy
End Sub
Sub RunThemAll()
Application.Run "Button193_Click"
Application.Run "CreateMail"
End Sub
Here's a worked example, tested in Office 2010:
'Copy range of interest
Dim r As Range
Set r = Range("B2:D5")
r.Copy
'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
'To paste as picture
wordDoc.Range.PasteAndFormat wdChartPicture
'To paste as a table
'wordDoc.Range.PasteExcelTable LinkedToExcel:=False, WordFormatting:=False, RTF:=False
Result:
In the code above I used early binding to have access to autocomplete; to use this code you need to set references to the Microsoft Outlook and Microsoft Word object libraries: Tools > References... > set checkmarks like this:
Alternatively, you can forget about the references and use late binding, declaring all the Outlook and Word objects As Object instead of As Outlook.Application and As Word.Document etc.
Apparently you're having trouble implementing the above; the range pastes as a table rather than a picture in your email message. I have no explanation for why that would happen.
An alternative is then to paste as an image in Excel, and then cut and paste that image into your e-mail:
'Copy range of interest
Dim r As Range
Set r = Range("B2:D5")
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
'Paste picture
wordDoc.Range.Paste
As pointed out by WizzleWuzzle, there is also the option of using PasteSpecial instead of PasteAndFormat or Paste...
wordDoc.Range.PasteSpecial , , , , wdPasteBitmap
... but for some reason, the resulting image doesn't render as well. See how the lower table is kind of blurry:
I am providing an alternative solution to the above problem as Outlook.MailItem.GetInspector.WordEditor does not work in some organizational environments.
For security purposes, the HTMLBody, HTMLEditor, Body and WordEditor properties all are subject to address-information security prompts because the body of a message often contains the sender's or other people's e-mail addresses. And, if Group Policy does not permit then these prompts do not come on-screen. In simple words, as a developer, you are bound to change your code, because neither registry changes can be made nor group policy can be modified.
Hence, if your code suddenly stopped working after migrating to Office 365 or for any other reasons, please refer to the code below. Comments have been added for easy understanding and implementation.
If you have administrative rights then try the registry changes given at below link:
https://support.microsoft.com/en-au/help/926512/information-for-administrators-about-e-mail-security-settings-in-outlo
However, as developer, I recommend a code that's rather compatible with all versions of Excel instead of making system changes because system changes will be required on each end user's machine as well.
Code Compatible: Excel 2003, Excel 2007, Excel 2010, Excel 2013, Excel 2016, Office 365
Option Explicit
Sub Create_Email(ByVal strTo As String, ByVal strSubject As String)
Dim rngToPicture As Range
Dim outlookApp As Object
Dim Outmail As Object
Dim strTempFilePath As String
Dim strTempFileName As String
'Name it anything, doesn't matter
strTempFileName = "RangeAsPNG"
'rngToPicture is defined as NAMED RANGE in the workbook, do modify this name before use
Set rngToPicture = Range("rngToPicture")
Set outlookApp = CreateObject("Outlook.Application")
Set Outmail = outlookApp.CreateItem(olMailItem)
'Create an email
With Outmail
.To = strTo
.Subject = strSubject
'Create the range as a PNG file and store it in temp folder
Call createPNG(rngToPicture, strTempFileName)
'Embed the image in Outlook
strTempFilePath = Environ$("temp") & "\" & strTempFileName & ".png"
.Attachments.Add strTempFilePath, olByValue, 0
'Change the HTML below to add Header (Dear John) or signature (Kind Regards) using newline tag (<br />)
.HTMLBody = "<img src='cid:DashboardFile.png' style='border:0'>"
.Display
End With
Set Outmail = Nothing
Set outlookApp = Nothing
Set rngToPicture = Nothing
End Sub
Sub createPNG(ByRef rngToPicture As Range, nameFile As String)
Dim wksName As String
wksName = rngToPicture.Parent.Name
'Delete the existing PNG file of same name, if exists
On Error Resume Next
Kill Environ$("temp") & "\" & nameFile & ".png"
On Error GoTo 0
'Copy the range as picture
rngToPicture.CopyPicture
'Paste the picture in Chart area of same dimensions
With ThisWorkbook.Worksheets(wksName).ChartObjects.Add(rngToPicture.Left, rngToPicture.Top, rngToPicture.Width, rngToPicture.Height)
.Activate
.Chart.Paste
'Export the chart as PNG File to Temp folder
.Chart.Export Environ$("temp") & "\" & nameFile & ".png", "PNG"
End With
Worksheets(wksName).ChartObjects(Worksheets(wksName).ChartObjects.Count).Delete
End Sub
dim objoutlook as object
dim objmail as object
dim rngto as range
dim rngsubject as range
dim rngbody1 as range
set dodata1 = new dataobject
set objoutlook = createobject ("outlook.application")
set objmail = objoutlook.createitem(0)
with activesheet
set rngto = .range("iv8")
set rngsubject = .range ("iv9")
set rngbody1 = .range(.range("a4:i8"), .range("a4").end(xldown))
rngbody1.copy
dodata1.getfromclipboard
end with
with objmail
.to = rngto.value
.subject = rngsubject.value
application.sendkeys ("{tab}")
doevents
application.sendkeys "(%{1068})"
doevents
.display
end with
sendkeys "^({v})", true
with objoutlook = nothing
with objmail = nothing
with rngto = nothing
with rngsubject = nothing
with rngbody1 = nothing
The code pastes Excel cells into an Outlook email. I also want to add a screenshot after I have pasted data from Excel into Outlook. I have tried it with sendkeys but this pastes the screenshot over previous Excel data.
Can anyone suggest a way to add the screenshot below the email body.
Code tested in Excel 2010
Private Sub PasteAtEnd()
'Set reference to Outlook in Tools | References
Dim objOutlook As Outlook.Application
Dim objMail As Outlook.MailItem
Dim myInspector As Outlook.Inspector
'Set reference to Word in Tools | References
Dim myDoc As Word.Document
On Error Resume Next
Set objOutlook = GetObject(, "outlook.application")
On Error GoTo 0
If objOutlook Is Nothing Then
Set objOutlook = CreateObject("outlook.application")
Set objMail = objOutlook.CreateItem(0)
objMail.Display
End If
' If outlook is already open,
' open a mailitem before running the code
Set myInspector = ActiveInspector.CurrentItem.GetInspector
' This line generates a warning message
Set myDoc = myInspector.WordEditor
' This simulates existing text
myDoc.Content.InsertAfter Chr(13) & "Paste Clipboard after all existing Content" & Chr(13)
' new line
myDoc.Content.InsertAfter Chr(13)
myDoc.Characters.last.Select
myDoc.Application.Selection.Paste
Set myInspector = Nothing
Set myDoc = Nothing
Set objOutlook = Nothing
End Sub