I already explained how to send emails automatically, but didn’t really focus on the content of the email. That is probably biggest problem of this method followers. In this article I’m going to show You how to cope with such issue and send Word document as email body.
The easiest way to have the content formatted properly is to copy text from Word and paste that to the created email. You cannot pass the content as string variable, because You will loose all the formatting.
Also there are other possibilities like adding HTML tags into the content, but this solution is good, when You have only 1 text. Not changeable, static, You know. And if it’s really long it would take a lot of time for tagging…
Anyway, back to the main topic, Word content to email body!
First of all, You need to copy the Word file content into the clipboard. To do that You need to create Word object and set the document – the equivalent of an Excel worksheet.
Set wd = CreateObject("Word.Application")
Set doc = wd.documents.Open("Word file path")Then You can copy the content of the document and store it in clipboard.
doc.Content.CopyNow comes the standard part of sending the email with a small modification. Instead of .Body You need to go to the WordEditor in your e-message.
Set editor = .GetInspector.WordEditorAfter that just paste the text stored in clipboard by pasting that into the content of the editor object.
editor.Content.PasteTo this moment everything is easy and clear.
There goes the tricky part
Unfortunately using .Send method the content of the email body is empty. It appears that copy-pasting method is working only for .Display email method.
But nobody said that You can’t combine those 2 methods together.
.Display
.SendIt is causing a small flicker – just before sending, the email is popping up for a split second, but this is the only way to make it work.
Code
Option Explicit
Sub WordDocAsBody()
Dim OutApp As Object, OutMail As Object
Dim wd As Object, doc As Object, editor As Object
Set wd = CreateObject("Word.Application")
Set doc = wd.documents.Open("Word file path")
doc.Content.Copy
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = "email address"
.Subject = "subject"
Set editor = .GetInspector.WordEditor
editor.Content.Paste
.Display
.Send
End With
doc.Close 0
Set OutMail = Nothing
Set wd = Nothing
Set OutApp = Nothing
MsgBox "Done"
End SubThat was the easiest way to have formatted text in the email body, the same way as in Word document. Although this has a small flicker, but I think we can consider this as the fastest and most comfortable way to send complex message using Outlook.
On ‘Set editor = .GetInspector.WordEditor’ I get “Run-time error ‘287’: Application-defined or object-defined error”.
I have Office, Word, Excel and Outlook 16.0 Object Library references selected.
Any suggestions?
Is Word the default email editor?
From the Inspector.WordEditor doc:
The WordEditor property is only valid if the IsWordMail method returns True and the EditorType property is olEditorWord . The returned WordDocument object provides access to most of the Word object model…
Thanks, quite simple and useful code!
Any idea why it adds 1 line spacing when copied to the Outlook email? Looks good and no spacing on the Word document, but it appears with 1 empty row between each line of the text on the Outlook message.
Hello Nikola!
Have You checked your Word doc for these marks?
I mean are You sure they are not 100% there, but only misformat whole text in new email?
You can try to replace every double new lines for 1 empty line if there is still a problem.
I work from two different PCs and keep the Word file I’d like to reference on Onedrive. Is there a way that I can use a URL to reference the Word doc?
Have You tried to just use the Word doc from Onedrive the same way as it is stored on PC?
If you use SharePoint you can host the file there to be accessed from multiple locations/pcs. Thats what I did for my team at work. I have an excel file that lets me choose which word template I want to send and it will open the document copy the content and paste it into a new Outlook email.
I am having a slight issue. Sometimes it will not copy the word content into the email and I have to close the email and run the macro again. 9 times out of 10 it works the second time. Other than that this macro works so well!!
Do you think there is a way to prevent this from happening?
Make sure that You close every file (Word) You opened.
Maybe try to give it a 1second break?
Or loop until macro copy the content of Word.
Probably it is the downside of opening those files from Sharepoint.
It happens whether or not its on SharePoint.
– I tried the 1 second break
– I have made sure the files are closed
Could you explain the loop until macro copies the content of Word?
Still seems to “forgets” to copy to email randomly.
You could try Do Until the email body contains the content of Word (any “specified word from Word content in email body) 🙂
Thanks for the advice. Do you mind sharing what you mean?
Maybe an example code? Here is what I am doing. Where do I put the loops?
——————————————————————-
Set WordDoc = WordApp.Documents.Open(filename:=DocLoc, ReadOnly:=False) ‘Open Template
WordDoc.Content.Copy
Set OutApp = CreateObject(“Outlook.Application”) ‘Create Outlook Application
Set OutMail = OutApp.CreateItem(0) ‘Create Email
With OutMail
.SentOnBehalfOfName = “Do not Send”
.BCC = “Testing – Do not Send”
.subject = “Testing 123”
.Attachments.Add
Set editor = .GetInspector.WordEditor
editor.Content.Paste
Application.CutCopyMode = False ‘Clears the Clipboard
.Display ‘To send without Displaying change .Display to .Send
———————————————————————
Im not sure if the issue is in the copy from Word or the paste to Outlook… Could be either. I think its the paste form outlook.
Try to loop the part, where You getting the content of Word and trying to paste. Check if the body of email contains any of “gold” phrase of Word content.
Could not get Loop to work.
But……….
I did find a work around. Before my email creation code I added an extra step of opening a new email, pasting content then closing email. This basically clears the error every time before it starts.
———————————
Set OutApp = CreateObject(“Outlook.Application”) ‘Create Outlook Application
OutApp.Visible = False ‘Make the application not visible to the user
Set OutMail = OutApp.CreateItem(0) ‘Create Email
With OutMail
Set EmailTemplate = OutMail.GetInspector.WordEditor
EmailTemplate.Content.Paste
End With
OutMail.Quit
OutApp.Visible = True ‘Make the application visible to the user
This works perfectly:
I had the editor select the email signature and delete it, then copy and paste the WordDoc content after that.
Set editor = OutMail.GetInspector.WordEditor
Set oBookmark = editor.Bookmarks(“_MailAutoSig”)
oBookmark.Select
editor.Windows(1).Selection.Delete
WordDoc.Content.Copy
editor.Content.Paste
Application.CutCopyMode = False ‘Clears the Clipboard
Happy to hear that! 🙂
Hi, when I am trying to run this code I am getting an error 5097 at the line Editor.content.paste
Can you please help me in this.
Hi Erica
Have You tried to restart your device? Or restart the Word and Outlook application?
Sometimes I am able to run the code, and other times I am not. I continue to get an error at editor.Content.Paste
Sub Send_Multiple_Emails()
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets(“Sheet1”)
Dim i As Integer
Dim OA As Object
Dim msg As Object
Dim wd As Object, doc As Object, editor As Object
Set OA = CreateObject(“outlook.application”)
Set msg = OA.createitem(0)
Set wd = CreateObject(“Word.Application”)
Set doc = wd.documents.Open(“C:\Users\60264\Desktop\MyFP&A\Macros\FP & A Macro Message.rtf”)
doc.Content.Copy
Dim last_row As Integer
last_row = Application.WorksheetFunction.CountA(sh.Range(“A:A”))
For i = 2 To last_row
msg.To = sh.Range(“A” & i).Value
msg.cc = sh.Range(“B” & i).Value
msg.Subject = sh.Range(“C” & i).Value
msg.attachments.Add sh.Range(“E” & i).Value
With msg
Set editor = .GetInspector.WordEditor
editor.Content.Paste
.Display
‘.Send
End With
sh.Range(“F” & i).Value = “Sent”
Next i
‘MsgBox “All e-mails have been sent successfully.”
End Sub
Hello Amra!
Try to get this part into Error handling brackets and implement there a loop -> loop until the code paste the Word content without any error
I have the word doc as an object in a sheet called “Email” (Object1) i have tried every way i can imagine to change the path to use that object rather than a different document. where am i going wrong?
This is what i have
Sub Mail_ActiveSheet()
‘ Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, Outlook 2010
Dim AString As String * 4096
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim strbody8 As String
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim xWs As Worksheet
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object
strDate = Format(Date – 1, “dddd dd mmm yyyy”)
Set wd = CreateObject(“Word.Application”)
Set doc = wd.documents.Open(Sheets(“Email”).OLEObject(“Object1”))
doc.Content.Copy
Set Sourcewb = ActiveWorkbook
‘ Next, copy the sheet to a new workbook.
‘ You can also use the following line, instead of using the ActiveSheet object,
‘ if you know the name of the sheet you want to mail :
‘ Sheets(“Sheet5”).Copy
ActiveSheet.Copy
Set Destwb = ActiveWorkbook
‘ Determine the Excel version, and file extension and format.
With Destwb
If Val(Application.Version) < 12 Then
' For Excel 2000-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
' For Excel 2007-2010, exit the subroutine if you answer
' NO in the security dialog that is displayed when you copy
' a sheet from an .xlsm file with macros disabled.
If Sourcewb.Name = .Name Then
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "You answered NO in the security dialog."
Exit Sub
Else
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End If
End With
' You can use the following statements to change all cells in the
' worksheet to values.
' With Destwb.Sheets(1).UsedRange
' .Cells.Copy
' .Cells.PasteSpecial xlPasteValues
' .Cells(1).Select
' End With
' Application.CutCopyMode = False
' Save the new workbook, mail, and then delete it.
TempFilePath = Environ$("temp") & "\"
TempFileName = ActiveSheet.Name & " " & Format(Now, "dd-mm-yy")
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, _
FileFormat:=FileFormatNum
On Error Resume Next
' Change the mail address and subject in the macro before
' running the procedure.
With OutMail
.To = ActiveSheet.Name
.CC = ""
.BCC = ""
.Subject = ActiveSheet.Name & " " & Format(Now, "dd-mm-yy") & " " & "- MANDATORY TRAINING"
Set editor = .GetInspector.WordEditor
editor.Content.Paste
.Display
.Attachments.Add Destwb.FullName
' You can add other files by uncommenting the following statement.
'.Attachments.Add ("C:\test.txt")
' In place of the following statement, you can use ".Display" to
' display the mail.
.Display
End With
On Error GoTo 0
.Close SaveChanges:=False
End With
' Delete the file after sending.
Kill TempFilePath & TempFileName & FileExtStr
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
First of all, clear code from unnecessary comments, they are not needed here, no help from them – longer code, much more illegible.
Second of all, what is the question – where is the problem / what is not working / what are You trying to achieve?
So I am emailing an attached copy of the active sheet to a email group (named the same as the sheet for ease). I have the above (i believe it is actually your code from another post) but i have played around with it so much now i have forgotten what is original.
So the email that goes with the attachment we change every now and then and the staff who do it are not the most tech savy. I built this as the process used to take 3-4 hours of copying each sheet, saving it to teams, sharing to email then importing the names from that sheet and checking email addresses.
I have added a word doc as an Object to a sheet called “Email”, I want it to copy what is in the object and paste that into the email but when i run this it just errors on
Set doc = wd.documents.Open(Worksheets(“Email”).OLEObject(“Object1”))
and i get run-time Error:’438′: Object does not support this property or method
I have cleared it up, sorry it has been 15 years since i did any VB coding.
Sub Mail_ActiveSheet()
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim xWs As Worksheet
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object
strDate = Format(Date – 1, “dddd dd mmm yyyy”)
Set wd = CreateObject(“Word.Application”)
Set doc = wd.documents.Open(Worksheets(“Email”).OLEObject(“Object1”))
doc.Content.Copy
Set Sourcewb = ActiveWorkbook
ActiveSheet.Copy
Set Destwb = ActiveWorkbook
With Destwb
If Val(Application.Version) < 12 Then
FileExtStr = ".xls": FileFormatNum = -4143
Else
If Sourcewb.Name = .Name Then
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "You answered NO in the security dialog."
Exit Sub
Else
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End If
End With
TempFilePath = Environ$("temp") & "\"
TempFileName = ActiveSheet.Name & " " & Format(Now, "dd-mm-yy")
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, _
FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.To = ActiveSheet.Name
.CC = ""
.BCC = ""
.Subject = ActiveSheet.Name & " " & Format(Now, "dd-mm-yy") & " " & "- MANDATORY TRAINING"
Set editor = .GetInspector.WordEditor
editor.Content.Paste
.Display
.Attachments.Add Destwb.FullName
.Display
End With
On Error GoTo 0
.Close SaveChanges:=False
End With
Kill TempFilePath & TempFileName & FileExtStr
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Hello
Do You consider another way of storing the .doc file, other than keeping that inside of the Excel?
Haven’t yet done or seen such thing. If You must do it like that, try to simulate double click on this object and then set to the Word object already opened one.
here is an image of the “Email” sheet showing the object.
https://ibb.co/nbPvj5X
Thanks,
This was informative and helpful.
Appreciate that!
If error is coming ‘word has encounter problem’ while pasting data from word document to outlook mail body, this can solved by doing click on outlook app and then any of folder like inbox or sent items. I was also facing same issue
Hi Naveen
Thanks for sharing your view! 🙂
Hi Tomasz,
Very informative article. Thank you for your effort.
What I try to achieve is to use the code with the multiple email bodies that are stored in different files.
In your code file path is declaired. I would like to use file path that is stored in the cell that offsets from another cell.
Would it be possible to use it with Offset(0,xx) somehow ?
Not really sure what I am doing as I try to copy and merge different codes from varius websites :/
Code:
‘
Sub WordDocAsBody()
Dim OutApp As Object, OutMail As Object
Dim wd As Object, doc As Object, editor As Object
Set wd = CreateObject(“Word.Application”)
Dim Sciezka As String
Sciezka = “\\xxx\xx\ankiety\”
Dim Odbiorcy As Range
Set Odbiorcy = Range(“A17”, Range(“A17”).End(xlDown))
Dim R As Range
For Each R In Odbiorcy
Set OutApp = CreateObject(“Outlook.Application”)
Set OutMail = OutApp.CreateItem(0)
‘
set doc = wd.documents.Open.<—-?
doc.Content.Copy
With OutMail
.SentOnBehalfOfName = "mail@mail.pl"
.To = R.Offset(0, 2)
.CC = R.Offset(0, 4)
.BCC = R.Offset(0, 5)
.Subject = R.Offset(0, 9)
Set editor = .GetInspector.WordEditor
editor.Content.Paste
.Display
'.Send
End With
doc.Close 0
Set OutMail = Nothing
Set wd = Nothing
Set OutApp = Nothing
Next R
End Sub
'
'
Kind regards
Piotr
Hello
Would it be possible to use it with Offset(0,xx) somehow ? – Yes, it is possible 🙂
Set Odbiorcy = Range(“A17”, Range(“A17”).End(xlDown)) – try to be more specified, refer to worksheet
set doc = wd.documents.Open.<—-? – the file path is needed to have opened specified file
Just give it a go and then share with us what are the results 🙂
Many thanks for the advice.
I have not clearly specified what I want to achieve, so this time I will be more specific.
File with macro contains a list of all recipients I would like to send email to.
Column A ( from A17 down) contains the username , in B there is language of the survey I would like to send, C stores email address (To:) , D – first name ; E – CC: ; F: BC: ; G – name of the file I would like as attachement ; J: Subject (different each time) ; K: – .docx file where the body of the email is kept (different depending on the language from column B) .
I would like to be able to send attachments (preferably multiple) ; to the recipients, where each recipient will receive email as follows:
In the body: Name ( from column D) + then body from the email specified (file name taken from the column K – file is stored on the network)
Multiple attachements ( if possible to use more than one attachement)
Code that I attach below is the closest to what I would like to achieve, but it only works with certain limitations:
– works only once after rebooting PC ; if I want to run it a second time, it hangs ( I assume I didnt close the word properly in the code)
– does not allow me to add first name ( column D) & body from the file ( R.Offset(0, 10))
-Only one body – hardcoded in the file specified can be attached
Sub PrzygotujMaile()
On Error Resume Next
Dim OutApp As Object
Dim OutMail As Object
Dim wd As Object
Dim doc As Object
Dim editor As Object
Dim Odbiorcy As Range
Dim R As Range
Set OutApp = CreateObject(“Outlook.Application”)
Set OutMail = OutApp.CreateItem(0)
Set wd = CreateObject(“Word.Application”)
Set Odbiorcy = Worksheets(“ankiety”).Range(“A17”, Worksheets(“ankiety”).Range(“A17”).End(xlDown))
Dim Sciezka As String
Sciezka = “\\network_path\folder\”
For Each R In Odbiorcy
Set OutMail = OutApp.CreateItem(0)
With OutMail
.SentOnBehalfOfName = “mail@mail.pl”
.To = R.Offset(0, 2)
.CC = R.Offset(0, 4)
.BCC = R.Offset(0, 5)
.Subject = R.Offset(0, 9)
.Attachments.Add (Sciezka & R.Offset(0, 8))
Set doc = wd.documents.Open(“\\network_path\folder\Mail_przewodni_pl.docx”) ‘ < — here instead of Mail_przewodni_pl.docx I woulld like to use value from cell R.Offset(0, 11)
doc.Content.Copy
Set editor = .GetInspector.WordEditor
editor.Content.Paste
.Display
End With
doc.Close 1
Set wd = Nothing
Next R
Set OutApp = Nothing
Set OutMail = Nothing
'Set wd = Nothing
End Sub
Hope this is more clear than previously.
Again , I appreciate your help.
Piotr
Hello
For sure You forgot to Quit the Word application, thats the first thing 🙂
Easier loop IMO would be something like:
For i = 17 to lastRow
and instead of .Offset You could just use .Cells(i, COLUMN_NUMBER).Value COLUMN_NUMBER => specified column for your needs.
Give me a sign how is it going with that 🙂
Tomasz,
Any idea how to get my code to do what I want it to do?
Regards
Piotr
Piotr,
I already gave You my suggestions, see above.
Have You tried those? 🙂
Hi Tomasz,
Sorry – getting older, half blind and not any wiser 😉 Didn’t see your reply.
Code does not work at allo now.
Not sure what I do wrong, its been almoset 20 years since I did any coding. Like a child in the fog now :/
Code looks as follows:
Sub PrzygotujMaile()
On Error Resume Next
Dim OutApp As Object
Dim OutMail As Object
Dim wd As Object
Dim doc As Object
Dim editor As Object
Dim i As Integer
Set OutApp = CreateObject(“Outlook.Application”)
Set OutMail = OutApp.CreateItem(0)
Set wd = CreateObject(“Word.Application”)
For i = 17 To lastRow
Set OutMail = OutApp.CreateItem(0)
With OutMail
.SentOnBehalfOfName = “mail@mail.pl”
.to = .Cells(i, 3).Value
.CC = .Cells(i, 5).Value
.BCC = .Cells(i, 6).Value
.Subject = .Cells(i, 10).Value
.Attachments.Add .Subject = .Cells(i, 12).Value
Set doc = wd.documents.Open(“\\network_path\folder\Mail_przewodni_pl.docx”)
doc.Content.Copy
Set editor = .GetInspector.WordEditor
editor.Content.Paste
.Display
doc.Close 0
Set OutMail = Nothing
Set wd = Nothing
Set OutApp = Nothing
End With
Next i
End Sub
What did I mess ut this time?
At the first glance looks fine.
What is the error?
Try to move .Display just under the With OutMail
And of course if You want to send it remember to add .Send 🙂
Genius!
thank you.
I now have a rich text ‘word doc embedded in excel’ source -> email machine with a search replace in the middle that can replace bits of the source with parameters calculated by excel, before then emailing the results.
I can’t praise the clarity of your description highly enough. 🙂
Thank You, I’m glad it could help You. 🙂
You can always consider buying me a coffee 🙂
https://www.buymeacoffee.com/SimpleExcelVBA
@Tomasz Płociński
There is no error message.
Even after moving .Display it just stays blank and does not do anything.
You did not set any value to lastRow, so the loop does not even start
–> so how You got a blank mail?
You create an email during loop AND once before for loop starts.