Excel VBA mail create and send error

[2368hewes]

I have 'acquired' the following code to create and email numerous mailitems with attachments. It works fine on office 2019 but shows an error (application defined or object defined error) on the highlighted line.

Sub sendEmailWithAttachments()

Dim OutLookApp As Object
Dim OutLookMailItem As Object
Dim myAttachments As Object
Dim row As Integer
Dim col As Integer

Set OutLookApp = CreateObject("Outlook.application")
row = 2
col = 1
ActiveSheet.Cells(row, col).Select
Do Until IsEmpty(ActiveCell)
workFile = Application.ActiveWorkbook.Path & "\" & "message.oft"
If FileExists(workFile) Then
Set OutLookMailItem = OutLookApp.CreateItemFromTemplate(workFile)
Else
MsgBox ("message.oft file does not exist in the folder!" & vbNewLine & _
"Also verify that the name is exactly 'message.oft'." & vbNewLine & _
"Exiting...")
Exit Sub
End If

Set myAttachments = OutLookMailItem.Attachments
'Do Until IsEmpty(ActiveCell)
Do Until IsEmpty(ActiveSheet.Cells(1, col))
With OutLookMailItem
If ActiveSheet.Cells(row, col).Value = "xxxFINISHxxx" Then
'MsgBox ("Exiting...")
Exit Sub
End If
If ActiveSheet.Cells(1, col).Value = "To" And Not IsEmpty(ActiveCell) Then
.To = .To & "; " & ActiveSheet.Cells(row, col).Value
ElseIf ActiveSheet.Cells(1, col).Value = "Cc" And Not IsEmpty(ActiveCell) Then
.CC = .CC & "; " & ActiveSheet.Cells(row, col).Value
'ElseIf ActiveSheet.Cells(1, col).Value = "Bcc" And Not IsEmpty(ActiveCell) Then
'.BCC = .BCC & "; " & ActiveSheet.Cells(row, col).Value
'ElseIf ActiveSheet.Cells(1, col).Value = "Reply-To" And Not IsEmpty(ActiveCell) Then
'.ReplyRecipients.Add ActiveSheet.Cells(row, col).Value
ElseIf ActiveSheet.Cells(1, col).Value = "attachment" And Not IsEmpty(ActiveCell) Then
attachmentName = ActiveSheet.Cells(row, col).Value
attachmentFile = Application.ActiveWorkbook.Path & "\" & attachmentName
If FileExists(attachmentFile) Then
myAttachments.Add Application.ActiveWorkbook.Path & "\" & ActiveSheet.Cells(row, col).Value
Else
MsgBox (Attachment & "'" & attachmentName & "'" & " file does not exist in the folder!" & vbNewLine & _
"Correct the situation and delete all messages from Outlook's Outbox folder before pressing 'Send Emails' again!" & vbNewLine & _
"Exiting...")
Exit Sub
End If
ElseIf ActiveSheet.Cells(1, col).Value = "xxxignorexxx" Then
' Do Nothing
Else
.Subject = Replace(.Subject, ActiveSheet.Cells(1, col).Value, ActiveSheet.Cells(row, col).Value)
'Write #1, .HTMLBody
.HTMLBody = Replace(.HTMLBody, ActiveSheet.Cells(1, col).Value, ActiveSheet.Cells(row, col).Value)
'ActiveSheet.Cells(10, 10) = .HTMLBody
End If

'MsgBox (.To)
End With
'Application.Wait (Now + #12:00:01 AM#)

col = col + 1
ActiveSheet.Cells(row, col).Select
Loop
OutLookMailItem.HTMLBody = Replace(OutLookMailItem.HTMLBody, "xxxNLxxx", "<br>")
OutLookMailItem.send
col = 1
row = row + 1
ActiveSheet.Cells(row, col).Select
Loop

End Sub

Public Function FileExists(ByVal path_ As String) As Boolean
FileExists = (Len(Dir(path_)) > 0)
End Function

 

[2368hewes]

Should read 'shows an error on office 2016'