VBA to create email with groupings: issue with saving to draft

[jd_palmer]

Hi,

I have adapted a great bit of code from Ron De Bruin that will create an email with grouped data depending on the email addresses. (Mail a row or rows to each person in a range)

The code works great but depending on the data I have it can create upwards of 100 emails. The code as per Ron uses ".Display" which will open up all 100+ emails and can be a bit of a pain.

This can be resolved by changing ".Display" to ".Save" which will create the email and save it in the draft folder of outlook. Again this works great for me using Outlook 2016 but when other people in the office use it (on Outlook 2015) it seems to add apostrophes either side of the email address which causes the email to be returned with an error once sent. The apostrophes are not added when using ".Display". e.g. example@email.co.uk becomes 'example@email.co.uk'


Delivery has failed to these recipients or groups:
'example@email.co.uk' (INVALID:example@email.co.uk)
This message was rejected by the recipient email system. Please check the recipient's email address and try resending this message, or contact the recipient directly.


Does anyone know why this is happening and, even better, know how I can resolve it?

This is the relevant section of code:

            If Cws.Cells(Rnum, 1).Value Like "?*@?*.?*" Then
            
                With Ash.AutoFilter.Range
                    On Error Resume Next
                    Set rng = .SpecialCells(xlCellTypeVisible)
                    On Error GoTo 0
                End With


                Set OutMail = OutApp.CreateItem(olMailItem)


                On Error Resume Next
                With OutMail
                    .To = Cws.Cells(Rnum, 1).Value
                    .Subject = Subb
                    .HTMLBody = Emsg & RangetoHTML(rng)
                    .Save
                End With
                On Error GoTo 0


                Set OutMail = Nothing
            End If

Thanks

 

[jd_palmer]

Anyone able to help out?

 

[Norgewalk]

I had this problem and it took me some time to figure out. I was once able to save draft emails using the email address as a string in the .To field example: Name@company.com but that stopped working for unknown reasons but I found a way around this is to resolve the email address and then use the resolved email address for the recipient.

Hope this helps others out, as I was unable to find anything online in my search!

'Get Email Address
Dim EmployeeEmail As String
    EmployeeEmail = Cws.Cells(Rnum, 1).Value
    'Example Email
    'EmployeeEmail = "Employee@Company.com"


    'CREATE THE EMAIL BODY TEXT
Dim EmailBodyText As String
    EmailBodyText = "Test Email Body Text"
    
Dim olApp As Outlook.Application
    Set olApp = CreateObject("Outlook.Application")
    
    'CREATE EMAIL
        Dim olMail As Outlook.MailItem
        Set olMail = olApp.CreateItem(olMailItem)


    'Resolve Email Address with Outlook
        Dim EmailTo As Outlook.Recipient
        Set EmailTo = olMail.Recipients.Add(EmployeeEmail)
            EmailTo.Resolve
        If EmailTo.Resolved Then
            Debug.Print "Resolved"
            EmailTo.Type = olTo 'This is for the .To
            'EmailTo.Type = olCC 'This is for the .CC
            'EmailTo.Type = olDCC 'This is for the .BCC
        Else
            Debug.Print "NOT Resolved"
        End If
        
        With olMail
        '.To = "" 'Using Resolved Email Above
        '.CC = "" 'Using Resolved Email Above
        '.BCC = "" 'Using Resolved Email Above
        .Subject = "Subject of Email - " & Date
        .HTMLBody = EmailBodyText
        .SendUsingAccount = olApp.Session.Accounts.Item(1)
        '.Display
        .Save
        '.Send
        
        End With


    Set olMail = Nothing
    Set olApp = Nothing
    Set EmailTo = Nothing