MS Outlook and Access: Recording Bounced Email Addresses

This is the start of a macro that will scan your Outlook Inbox or a subfolder named “Bounces” for bounce messages, and record such messages to an Access database.

The BouncingEmails.mdb files contains a single table, named “bounces”, that has a single column named “email”.

This code will only match qmail and the Exchange server’s bounce messages. Each server has its own message format, so needs a little code for each bounce.

' This scans the current folder and copies the bouncing email address to
' C:DBBouncingEmails.mdb

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=BouncingEmails.mdb;" & _
                    "DefaultDir=C:DB;" & _
                    "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 bouncing (`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)
                    conn.Execute "INSERT INTO bouncing (`email`) VALUES ('" & address & "')"
                    mail.Delete
            End If
        
        End If ' lines.count > 7
    Next
    conn.Close
    Exit Sub
' called if the bounces folder does not exist
NoBounces:
    Set bounces = inbox
    Resume Next
End Sub