PDA

View Full Version : [SOLVED] How to send email in excel using content in word as email body



MMM13
08-16-2017, 07:00 AM
Hi,
Newbie here.
I have the below code which works great as it is. In the code, the message that is meant for the email is written in HTML in the VBA code. I am trying to now change the code so the email body is taken from a word document. As well as this feature, I am also trying to use a Word Document Object or a textbox within Excel to compose the body and use it in the email, via a macro. Another feature that I would also like to implement would be to add attachments to the email via Excel VBA code.
Every guidance appreciated.
Thank you in advance!


Sub Send_Files()
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
Dim rng As Range
Dim strbody
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set sh = Sheets("TestingSheet") 'Use "TestingSheet" for actual tests, "Test" for actually sending the emails
Set OutApp = CreateObject("Outlook.Application")
strbody = "<HTML>Hi, <br /><br />"
strbody = strbody & "<br /><br />"
strbody = strbody & "<br /><br />"
strbody = strbody & "br /><br />"
strbody = strbody & "<br /><br />"
strbody = strbody & ".<br /><br />"
strbody = strbody & "br /><br />"
strbody = strbody & ".<br /><br />"
strbody = strbody & ".<br /><br /> "
strbody = strbody & "Kind Regards,<br /><br />"
strbody = strbody & "</html>"
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
.BodyFormat = olFormatHTML
.To = cell.Value
.Subject = "Information Governance Training"
.HTMLbody = strbody
.SendUsingAccount = OutApp.Session.Accounts.Item(1)
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
'.Display
.Send
End With
End If
Set OutMail = Nothing
Next cell
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub

mdmackillop
08-16-2017, 07:38 AM
To get the Word content



Pth = "F:\Lorem.docx"
strbody = WordTxt(Pth)


Function WordTxt(Pth)
On Error Resume Next
Set wrdapp = GetObject(, "Word.Application")
If Err.Number <> 0 Then 'Word isn't already running
Set wrdapp = CreateObject("Word.Application")
End If
On Error GoTo 0
WordTxt = wrdapp.documents.Open(Pth).Content
wrdapp.Quit
Set wrdapp = Nothing
End Function


Your code already contains lines to get attachments

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



or more simply

.Attachments.Add ("File full path")

MMM13
08-16-2017, 07:49 AM
Thank you for a quick response!

Edited reply post:

I got the word content working! thank you so much.
When executing the code, the email I receive as a test has lost it's format. If possible, how can I alter this so the email body has the same format as the word document?

Thank you

mdmackillop
08-16-2017, 08:21 AM
The inserted text is not formatted. That's beyond my ken.


Sub Send_Files()
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
Dim rng As Range
Dim strbody
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set sh = Sheets("TestingSheet") 'Use "TestingSheet" for actual tests, "Test" for actually sending the emails

Pth = "F:\Lorem.docx" '<======= Change to suit
strbody = WordTxt(Pth)

Set OutApp = CreateObject("Outlook.Application")
strbody = "<HTML>Hi, <br /><br />"
strbody = strbody & strtxt & "<br /><br />"
strbody = strbody & "Kind Regards,<br /><br />"
strbody = strbody & "</html>"
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
.BodyFormat = olFormatHTML
.To = cell.Value
.Subject = "Information Governance Training"
.HTMLbody = strbody
.SendUsingAccount = OutApp.Session.Accounts.Item(1)
'.Attachments.Add ("File full path")

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
.Display
'.Send
End With
End If
Set OutMail = Nothing
Next cell
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub


Function WordTxt(Pth)
On Error Resume Next
Set wrdapp = GetObject(, "Word.Application")
If Err.Number <> 0 Then 'Word isn't already running
Set wrdapp = CreateObject("Word.Application")
End If
On Error GoTo 0
WordTxt = wrdapp.documents.Open(Pth).Content
wrdapp.Quit
Set wrdapp = Nothing
End Function

MMM13
08-16-2017, 08:41 AM
Thank you so much for your help!
I greatly appreciate it :).

Your recent code works really well.

I added:

Set OutApp = CreateObject("Outlook.Application")
strbody = "<HTML>Hi, <br /><br />"
strbody = strbody & strtxt & WordTxt(Pth) & "<br /><br />"
strbody = strbody & "Kind Regards,<br /><br />"

This brings the word document into the email now, however format is still not the same as in the word document.

I then added HTML break lines at the end of paragraphs in the word document (<br /><br />), and this seems to have created new paragraphs.

mdmackillop
08-16-2017, 09:16 AM
Sub Send_Files()
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
Dim rng As Range
Dim objDoc As Object
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set sh = Sheets("TestingSheet") 'Use "TestingSheet" for actual tests, "Test" for actually sending the emails


WordTxt ("F:\Lorem.docx") '<======= Change to suit


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
.BodyFormat = olFormatHTML
.To = cell.Value
.Subject = "Information Governance Training"
.SendUsingAccount = OutApp.Session.Accounts.Item(1)
'.Attachments.Add ("File full path")


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
.Display
'.Send
End With


Set objInspector = OutApp.ActiveInspector
If Not objInspector Is Nothing And objInspector.EditorType = olEditorWord Then
Set objDoc = objInspector.WordEditor
objDoc.Range.Paste
End If


End If
Set OutMail = Nothing
Next cell
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub




Function WordTxt(Pth)
On Error Resume Next
Set wrdapp = GetObject(, "Word.Application")
If Err.Number <> 0 Then 'Word isn't already running
Set wrdapp = CreateObject("Word.Application")
End If
On Error GoTo 0
WordTxt = wrdapp.documents.Open(Pth).Range.Copy
wrdapp.Quit
Set wrdapp = Nothing
End Function

MMM13
08-17-2017, 03:17 AM
Thank you for your help! :)

MMM13
08-17-2017, 06:22 AM
Is there any way that the word document can be converted to html when the macro runs? in order for the format to be same in the email as it is in the word document?

Found:
"RangetoHTML = ts.ReadAll"