MS Access, Outlook: recording bounced email addresses

This is a subroutine that will scan your Outlook inbox or a subfolder of inbox named "Bounces", and copy bounced email addresses to a MS Access database.

It will then join the table of bad addresses to another table (of people, presumably) and null out the bad addresses, so you won't send to them again.

This code is pretty jacked up, but, it works for my specific configuration, which is Outlook as the client, Exchange as the server. Many addresses won't be detected, because Exchange removes the internet email address, substituting the user's real-world name instead. For those, you'll have to manually remove the addresses.

(The problem here is "indirection". Outlook and Exchange try to hide the ugly internet email addresses, and use a more complex system that allows you to use the user's real name, and have it resolve to a record in a directory. That record contains the real address, whether it's an X.400, internet, or Exchange address. The problem with this is roughly the same problem people have with phones, when they use speed dial or memory dial all the time -- they forget the underlying phone number. In this situation, with the email address, it's the server deliberately losing the underlying email address.)


Public Sub CopyBouncedAddressesToDatabase()
    Dim conn As New ADODB.Connection
    Dim cmd As New ADODB.Command
    Dim rs As New ADODB.Recordset
    Dim AccessConnect As String
    
    AccessConnect = "Driver={Microsoft Access Driver (*.mdb)};" & _
                    "Dbq=DATABASE.mdb;" & _
                    "DefaultDir=C:\DATABASE;" & _
                    "Uid=Admin;Pwd=;"
    conn.Open AccessConnect
    
    Dim inbox, bounces As Outlook.MAPIFolder
    Dim mail As Variant
    Dim body As String
    Dim lines As Variant
    Dim address As Variant
    Dim addressarray As Variant
    
    Set inbox = Outlook.Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
    
    On Error GoTo NoBounces
    Set bounces = inbox.Folders.item("Bounces")
    On Error GoTo 0

    ct = bounces.Items.Count
    For i = ct To 1 Step -1
        Set mail = bounces.Items(i)
        lines = Split(mail.body, vbCrLf, 50)
        
        If UBound(lines) > 7 Then
        
            If lines(1) = "I'm afraid I wasn't able to deliver your message to the following addresses." _
                And InStr(lines(4), "@") Then
                    ' matches qmail bounces
                    address = Mid(lines(4), 2)
                    address = Left(address, Len(address) - 2)
                    conn.Execute "INSERT INTO tmpBouncingEmails (`email`) VALUES ('" & address & "')"
                    mail.Delete
            ElseIf lines(0) = "Your message did not reach some or all of the intended recipients." _
                And InStr(lines(7), "@") Then
                    ' matches exchange bounces
                    address = LTrim(lines(7))
                    addressarray = Split(address)
                    address = addressarray(0)
                    address = Replace(address, "'", "")
                    conn.Execute "INSERT INTO tmpBouncingEmails (`email`) VALUES ('" & address & "')"
                    mail.Delete
            ElseIf lines(0) = "Your message did not reach some or all of the intended recipients." _
                And (InStr(lines(9), "unknown user account>") _
                        Or InStr(lines(9), "User unknown>") _
                        Or InStr(lines(9), "No such user") _
                        Or InStr(lines(9), "Address rejected") _
                        Or InStr(lines(9), "Invalid recipient") _
                        Or InStr(lines(9), "User account is unavailable") _
                        Or InStr(lines(9), "Addressee unknown") _
                        Or InStr(lines(9), "Unable to deliver to") _
                        Or InStr(lines(9), "smtp;550") _
                    ) _
                Then
                    ' matches exchange bounces
                    address = LTrim(lines(9))
                    addressarray = Split(address)
                    offs = 1
                    For offs = 1 To UBound(addressarray)
                        If InStr(addressarray(offs), "@") Then Exit For
                    Next
                    If offs <= UBound(addressarray) Then
                        address = addressarray(offs)
                        address = Replace(address, "...User", "")
                        address = Replace(address, "'", "")
                        address = Replace(address, "<", "")
                        address = Replace(address, ">:", "")
                        address = Replace(address, ">...", "")
                        address = Replace(address, ">", "")
                        address = Replace(address, "(", "")
                        address = Replace(address, ")", "")
                        conn.Execute "INSERT INTO tmpBouncingEmails (`email`) VALUES ('" & address & "')"
                        mail.Delete
                    End If
            ElseIf lines(1) = "Unable to deliver message to the following address(es)." _
                And InStr(lines(4), "@") Then
                    ' matches first bounce in a yahoo.com bounce
                    address = LTrim(lines(4))
                    addressarray = Split(address)
                    address = addressarray(7)
                    address = Replace(address, "(", "")
                    address = Replace(address, ")", "")
                    conn.Execute "INSERT INTO tmpBouncingEmails (`email`) VALUES ('" & address & "')"
                    mail.Delete
            ElseIf lines(0) = "Your message did not reach some or all of the intended recipients." _
                And (InStr(lines(9), "User account is overquota") Or _
                        InStr(lines(10), "User account is overquota")) Then
                    ' just ignore this message - account is good
                    mail.Delete
            ElseIf lines(0) = "Your message did not reach some or all of the intended recipients." Then
                    ' at this point, we don't have an address for them
                    ' so we'll just log their outlook contact name or something
                    ' fixme
            End If
        
        End If ' lines.count > 7
    Next
    
    ' null out the bouncing email addresses
    conn.Execute "UPDATE tmpBouncingEmails INNER JOIN tblPeople ON tblPeople.email = tblPeople.Email SET tblPeople.Email = Null"
    ' clear out the temporary table
    conn.Execute "DELETE * FROM tmpBouncingEmails"
    conn.Close
    Exit Sub
' called if the bounces folder does not exist
NoBounces:
    Set bounces = inbox
    Resume Next
End Sub