How to Send a HTML Email using Word Email Template using Excel Macro

[MMM13]

Hi,

Newbie here;
I have the below code that emails the contacts within the excel spreadsheet, with attachments.
I am trying to use a Word object in excel to edit the content of the email body, which then converts to HTML when the macro runs for it to be used in the email body keeping its format.

At the moment, the code opens the email for preview and the content in the Word object is not in the email body, the name of the word object does however appear in the email body.


Any help is appreciated.
Thanks 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 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 ("C:") '<======= 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 = "" <=====enter subject
.SendUsingAccount = OutApp.Session.Accounts.Item(1)
.HTMLBody = WordToOutlook(rng)
'.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


Public Function WordToOutlook(ByVal rng As Range)
TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".doc"
Set selectRange = rng
Set WDObj = ThisWorkbook.ActiveSheet.OLEObjects("ProjectAccuracy")
WDObj.Activate
WDObj.Object.Application.Visible = True
Set WDApp = GetObject(, "Word.Application")
Set WDDoc = WDApp.ActiveDocument
'Save as HTML
WDDoc.SaveAs TempFile, FileFormat:=8
WDDoc.Close savechanges:=False
WDApp.Quit
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
Application.DisplayAlerts = True
Set WDDoc = Nothing
Set WDApp = Nothing
Set oEmbFile = Nothing
Kill TempFile
Set ts = Nothing
Set fso = Nothing
'Return Value
WordToOutlook = RangetoHTML
End Function

[MMM13]



[MMM13]

I have managed to get the code to do what I would like it to do, however I am getting this message:

"Run-time error '91':
Object variable or With block variable not set"

Highlighted line when debugging:
If Not objInspector Is Nothing And objInspector.EditorType = olEditorWord Then

Any idea why?
Thank you

[MMM13]

I have solved this by using the below code:



On Error Resume Next
' your code that may cause an error
If Err.Number = 91 Then
MsgBox "Invalid Name"
Exit Sub
End If

This is now not needed:
WordTXT("C:")