Parse Bounced Email (delivery-report)

For many email campaign applications, the very important task is detecting if the email is received by recipient or not. Parsing the delivery report is the common way to get the email status. The following sample demonstrates how to parse the delivery-report.

Example

[Visual Basic] The following example demonstrates how to parse the delivery report with ANPOP POP3 & IMAP4 Component.

[Visual Basic]
Public Sub ParseReport(ByVal emlFile As String)
    Dim oMsg As ANPOPLib.POPMSG
    Set oMsg = CreateObject("ANPOP.POPMSG")
    If oMsg.ImportFile(emlFile) <> 0 Then
        MsgBox "load eml file failed!"
        Exit Sub
    End If
    
    Dim contentType As String '
    contentType = LCase(oMsg.GetHeaderItem("Content-Type"))

    If InStr(1, contentType, "multipart/report") < 0 Then
        'not delivery report
        MsgBox "This is not a delivery report."
        Exit Sub
    End If

    Dim recipient As String
    Dim messageid As String
    Dim status As String
    status = "failed"

    Dim nCount As Integer
    nCount = oMsg.GetAttachmentCount()
    Dim src As String
    If nCount > 0 Then
        src = StrConv(oMsg.GetAttachmentChunk(1), vbUnicode)
        If InStr(1, contentType, "disposition-notification", vbTextCompare) > 0 Then
            'this is a read receipt
            status = "delivered"
            messageid = GetHeaderValue("Original-Message-ID:", src)
            recipient = GetHeaderValue("Final-Recipient:", src)
        Else
            'this is a delivery report
            status = GetHeaderValue("Action:", src)
            messageid = GetHeaderValue("Original-Message-ID:", src)
            recipient = GetHeaderValue("Final-Recipient:", src)
            If Len(messageid) = 0 And nCount > 1 Then
                'get message id from original headers/message
                src = StrConv(oMsg.GetAttachmentChunk(2), vbUnicode)
                messageid = GetHeaderValue("Message-ID:", src)
            End If
        End If
    Else
        'this delivery report doesn't contain the report attachment, parse the body text
        status = "failed"
        src = oMsg.GetBodyText()
        recipient = SearchFirstEmailAddr(src)
        messageid = GetHeaderValue("Message-ID:", src)
    End If

    Dim pos As Integer
    pos = InStr(1, recipient, ";")
    If pos > 0 Then
        recipient = Mid(recipient, pos + 1)
    End If

    fnTrim recipient, "<> "
    MsgBox "This is a delivery report."
    MsgBox "Recipient: " & recipient
    MsgBox "Message-ID: " & messageid
    MsgBox "Status: " & status
End Sub


Public Function GetHeaderValue(ByVal key As String, _
ByVal src As String) As String
    Dim lines() As String
    lines = Split(src, Chr(10))
    Dim count As Integer
    Dim i As Integer
    For i = LBound(lines) To UBound(lines)
        Dim s As String
        s = lines(i)
        fnTrim s, " " & vbTab & vbCrLf
        If Len(s) > 0 Then
            If InStr(1, s, key, vbTextCompare) = 1 Then
                s = Mid(s, Len(key))
                fnTrim s, " " & vbTab & vbCrLf
                GetHeaderValue = s
                Exit Function
            End If
        End If
    Next
    GetHeaderValue = ""
End Function

Public Function SearchFirstEmailAddr(ByVal src As String) As String
    SearchFirstEmailAddr = ""
    Dim pos As Integer
    pos = InStr(1, src, "@")
    If pos < 0 Then
        Exit Function
    End If

    Dim addr As String
    Dim endpos As Integer
    endpos = strpbrk(src, pos, "<> ;,:" & vbTab & vbCrLf)
    Dim startpos As Integer
    startpos = strpbrkr(src, pos, "<> ;,:" & vbTab & vbCrLf)
    If endpos > 0 And startpos > 0 Then
        addr = Mid(src, startpos, endpos - startpos)
        fnTrim addr, "<> ;,:" & vbTab & vbCrLf
    End If
    SearchFirstEmailAddr = addr
End Function

Function strpbrk(src, start, charset)
    strpbrk = 0
    Dim i, size, pos, ch
    size = Len(src)
    For i = start To size
        ch = Mid(src, i, 1)
        If InStr(1, charset, ch) >= 1 Then
            strpbrk = i
            Exit Function
        End If
    Next
End Function

Function strpbrkr(src, start, charset)
    strpbrkr = 0
    Dim i, size, pos, ch
    size = Len(src)
    For i = start To 1 Step -1
        ch = Mid(src, i, 1)
        If InStr(1, charset, ch) >= 1 Then
            strpbrkr = i
            Exit Function
        End If
    Next
End Function

Function fnTrim(ByRef src, trimer)
    Dim i, nCount, ch
    nCount = Len(src)
    For i = 1 To nCount
        ch = Mid(src, i, 1)
        If InStr(1, trimer, ch) < 1 Then
            Exit For
        End If
    Next
    
    src = Mid(src, i)
    nCount = Len(src)
    For i = nCount To 1 Step -1
        ch = Mid(src, i, 1)
        If InStr(1, trimer, ch) < 1 Then
            Exit For
        End If
    Next
    src = Mid(src, 1, i)
End Function

2001-2007 © Copyright AdminSystem Software Limited. All rights reserved.