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