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:")