Automated email generation not resolving multiple recipients

Question

I have a VBA script which creates & saves Draft emails. To add recipients, it pulls a string from a linked Excel table and adds that to the Recipients object.

For emails with single recipients, this works like a charm. All the user needs to do is open the draft, spend 5 seconds looking it over, and hit Send.

The problem occurs with several contacts at once (e.g. "[email protected]; [email protected]; [email protected]"). When the user hits Send, Outlook will pop up a Check Names dialogue with no suggestions. The user can get around this by clicking on the To field and entering a dummy semicolon to trigger the auto resolve. I'd like to avoid this since this process creates well over a hundred emails at a time which need to be individually reviewed.

Looking around on the net, I've found and tried Recipients.ResolveAll which returns false. I suspect the reason is that Outlook is trying to resolve the entire string of recipients at once and not individually. So my question is: how do I get Outlook to stop displaying this Check Names dialogue? Do I need to loop thru my email string and parse out the individual emails?

Sub CreateEmail(id as Integer)
    Dim OlApp As Outlook.Application
    Dim ObjMail As Outlook.MailItem
    Dim Recipients As Outlook.Recipients
    Dim CurrentRecipient As Outlook.Recipient

    Set OlApp = CreateObject("Outlook.Application")
    Set ObjMail = OlApp.CreateItem(olMailItem)
    Set Recipients = ObjMail.Recipients

    Dim StrEmailTo As String
    StrEmailTo = CurrentDb.OpenRecordset( _
        "Select [Emails] from LU_Contacts where id=" & id & ";").Fields(0)

    Set CurrentRecipient = Recipients.Add(StrConv(StrEmailTo, 3))
    CurrentRecipient.Type = olTo
    ...

    Objmail.Save

Answer 1

Recipients.Add takes a single email address.

If you wish to have multiple recipients, call Recipients.Add for each one.

If your string is returned in a ; delimited format, then something like:

dim EmailList as variant
dim NumEmails as long
dim AddEmailLoop as long

EmailList=split(StrEmailTo,";")
NumEmails=UBound(EmailList)

For AddEmailLoop=0 to NumEmails
    Recipients.add(EmailList(AddEmailLoop))
next

should allow you to add the entire list