This sample uses the EasyMail POP3 object to download each message in our bounce box. Each message is parsed and the body text is scanned for specific phrases to determine if the message is a hard or a soft bounce. Once the code determines the type of bounce, it parses the id off of the To: address which identifies the address in our database. If the To: address does not begin with "bounce" it scans the received headers for the bounce address by using the TimeStamps collection. The sample then updates the bounce_soft and bounce_hard fields in the database accordingly before deleting the message from the bounce box. If the type of bounce can not be determined it is left in the bounce box for human analysis which will be used to improve the phrase scanning code in the future. The phrases used to identify bounced messages are read from an XML file.
'To do: Set the following variables:
strLicenseKey = "Newsletter Sample/02E00220B529204B62"
strMailServer= "mail.yourdomain.com"
strAccount= "bounce_account"
strPassword= "bounce_password"
'End To Do
Main
Sub Main()
Dim objPOP3, nCnt
Dim nBounceType, nId, nPos1, nPos2
Dim strBodyText, strToAddr, nOrdinal
Dim strConnection, nRetVal
'create the EasyMail POP3 object and assign
'the basic properties
Set objPOP3 = CreateObject("EasyMail.POP3") objPOP3.LicenseKey = strLicenseKey
objPOP3.MailServer = strMailServer
objPOP3.Account = strAccount
objPOP3.Password = strPassword
'connect to the mail server
nRetVal = objPOP3.Connect()
If Not nRetVal = 0 Then
MsgBox "Error connecting to mail server."
exit sub
End If
'prepare the database and select our e-mail table
Set cnnData = CreateObject("ADODB.Connection") strConnection = "DBQ=email_database.mdb"
cnnData.Open "DRIVER=" &_
"{Microsoft Access Driver (*.mdb)};" &_ strConnection
Set rs = CreateObject("ADODB.RecordSet") rs.Open "SELECT * FROM email_table", cnnData, 1, 3
'get the count of messages waiting in the
'bounce box and download and process each one
nCnt = objPOP3.GetDownloadableCount()
For x = 1 To nCnt
nOrdinal = objPOP3.DownloadSingleMessage(x)
If nOrdinal < 0 Then
MsgBox "There was an error downloading " &_
"the message. " & nOrdinal
exit sub
End If
strBodyText = objPOP3.Messages(nOrdinal).BodyText
'get id from To: address
set objMsgs = objPOP3.Messages
For Each Recip In objMsgs(nOrdinal).Recipients
strToAddr = Recip.Address
If LCase(Left(strToAddr, 6)) = "bounce" Then
Exit For
End if
Next
'if address is not found then try searching
'timestamps (AKA received headers)
If Not LCase(Left(strToAddr, 6)) = "bounce" Then
For Each TimeS In objMsgs(nOrdinal).Timestamps
strToAddr = TimeS.For
If LCase(Left(strToAddr, 6)) = "bounce" Then
Exit For
End if
Next
End If
'if it is a bounce message we will process it
If Left(strToAddr, 6) = "bounce" And _
InStr(strToAddr, "_") Then
nPos1 = InStr(strToAddr, "_") + 1
nPos2 = InStr(strToAddr, "@")
If nPos2 > nPos1 Then
nId = Mid(strToAddr, nPos1, nPos2 - nPos1)
End If
'call the IdentifyBounce routing which scans
'the bodytext for the phrases found in our
'xml file
nBounceType = IdentifyBounce(strBodyText)
If nBounceType > 0 Then
'the message has been identified as a hard
'or soft bounce so update the database
rs.Find ("id=" & nId) If rs.EOF = False and rs.BOF=False Then
If nBounceType = 1 Then
rs("soft_bounces")=rs("soft_bounces")+1 Else
rs("hard_bounces")=rs("hard_bounces")+1 End If
'update changes
rs.update
End If
'delete the message from the bounce box
objPOP3.DeleteSingleMessage x
elseif nBounceType = 0 then
'If nBounceType is 0 then it is a warning
'message or auto-responsea so we will
'delete the message from the bounce box.
objPOP3.DeleteSingleMessage x
End If
End If
'free resources used by the parsed message. This
'call does not delete messages from the server.
objPOP3.Messages.DeleteAll
Next
'disconnect from mail server
'and free remaining resources
objPOP3.Disconnect
rs.Close
msgbox "Operation Complete."
End sub
Function IdentifyBounce(strBodyText)
Set st = CreateObject("ADODB.Stream") Set rs = CreateObject("ADODB.RecordSet")
st.Open
st.LoadFromFile ("bounce_signatures.xml")
rs.Open st
rs.Sort = "weight DESC"
IdentifyBounce = -1
Do While Not rs.EOF
If InStr(1, strBodyText, rs("signature"), _ vbTextCompare) Then
IdentifyBounce = rs("weight") End If
rs.MoveNext
Loop
rs.Close
End Function
