Sending email working in Older version but not working in latest version of Excel-CodePudding

Every month I need to send hundred of emails to our suppliers and customers. For that I was using an Excel VBA to send multiple emails with multiple attachments from a list of email addresses and file names in an Excel table.

Excel VBA Source Link: https://github.com/sotirop/mergelook

But recently our IT team has updated our MS Excel from MS 2016 to MS 365 and OS to Windows 10.

Now I getting an error of -

'Run-time error '287': application-defined or object-defined error'

Gives error at line

.To = .To & "; " & ActiveSheet.Cells(row, col).Value

Type of VBA Error Screenshot

Line that gives an Error Screenshot

Please find the code that work on older version of excel but not in MS 365 and OS to Windows 10.

Any help to fix it would be greatly appreciated. Thank you so much in advance.

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 = Cells(ActiveCell.row, 17).Value & "\" & attachmentName
                If FileExists(attachmentFile) Then
                    myAttachments.Add Cells(ActiveCell.row, 17).Value & "\" & 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

CodePudding user response：

Expanding on my comment above: it is a really bad idea to use To / CC / BCC properties as intermediary variables. Introduce dedicated variables and build them instead. Once you are out of the loop, set the To / CC / BCC properties without ever reading them.

vTo = "";
Do Until IsEmpty(ActiveSheet.Cells(1, col))
  ...
  If ActiveSheet.Cells(1, col).Value = "To" And Not IsEmpty(ActiveCell) 
  Then
     vTo  = vTo  & "; " & ActiveSheet.Cells(row, col).Value
     ...
Loop
OutLookMailItem.To = vTo

CodePudding user response：

I'd recommend using the Recipients property of the MailItem class to set recipients and then calling the ResolveAll method which attempts to resolve all the Recipient objects in the Recipients collection against the Address Book. For example:

 Set myRecipient = MyItem.Recipients.Add("Eugene Astafiev")
 myRecipient.Resolve 
 If myRecipient .Resolved Then 
   myItem.Subject = "Test task" 
   myItem.Display 
 End If

See How To: Fill TO,CC and BCC fields in Outlook programmatically for more information.