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