Outlook 2003 - filtering undeliverables

Hello -

Our webmaster sends out a monthly newsletter to thousands of recipients. Each month this results in hundreds of undeliverable messages.
The undeliverables are generally very helpful with why they were not delivered, account does not exist, SMTP problem, etc. I have tried setting up rules to filter on the body of the undeliverable in an attempt to better organize the mess but they do not work.

For example - If I set up a rule to look for the words 'account does not exist' in the body of the message and move it to a specific folder this results in maybe one or two messages being filtered when there are actually dozens.

I have tried moving the rule to the top of the list and not processing further rules with no success.

Does anyone have an idea on this?

Who is Participating?
David LeeCommented:

The macro is below.  It's quite simple.  It watches for messages as they arrive in the inbox.  When one, or more, does, then the macro filters out all messages save those with a subject line of "Delivery Status Notification (Failure)".  You can change that to something else if you want.  If there are any messages with that subject line, the macro then processes each one looking for one of the listed causes in the body of the message.  If it finds a match, it moves the message to the designated folder for that type of failure.  If no match is found, the message is ignored.

To use this macro, do the following:
1.  Start Outlook
2.  Click Tools->Macro->Visual Basic Editor
3.  If not already expanded, expand Microsoft Office Outlook Objects and click on ThisOutlookSession
4.  Copy the code below and paste it into the right-hand pane of the VB Editor window
5.  Edit the code making the changes per the comments I embeded in the code.  You can also add more non-delivery report message types at this point.  For each one you'll need to duplicate this block of code:

                If InStr(1, olItems.Item(intCounter).Body, "text") > 0 Then
                    olItems.Item(intCounter).Move SomeFolder
                End If

If you want each message type to go into its own folder, then you'll also need to duplicate this line of code once for each folder:

    Set olSMTPFailedFolder = OpenMAPIFolder("\MailboxOrFolderName\Folder Name")

6.  Click the diskette icon on the toolbar to save the changes
7.  Close the VB Editor
8.  Click Tools->Macro->Security
9.  Set the Security Level to Medium
10.  Close Outlook
11.  Start Outlook
12.  Outlook will display a dialog-box warning that ThisOutlookSession contains macros and asking if you want to allow them to run.  Say yes.
13.  If you have some non-delivery reports, move or copy them to your inbox then send yourself a message to trigger an arrival event and kick off the macro.  

That's it.  I tested this as best I could.  Unfortunately, I don't have any way to generate all the possible non-delivery message types so I couldn't give it a thorough test.  I wrote this using Outlook 2002 but it should work without any problems on 2003.  

'Macro Begins Here
Private WithEvents objInboxItems As Items

Private Sub Application_Startup()
    Dim objNS As NameSpace
    Set objNS = Application.GetNamespace("MAPI")
    Set objInboxItems = objNS.GetDefaultFolder(olFolderInbox).Items
    Set objNS = Nothing
End Sub

Private Sub Application_Quit()
    Set objInboxItems = Nothing
End Sub

Private Sub objInboxItems_ItemAdd(ByVal Item As Object)
    Dim intCount As Integer, _
        olItems As Items, _
        olSMTPFailedFolder As Outlook.MAPIFolder
    'Replace the path on the next line with the MAPI path to the folder on your system.  Tha path must begin with \
    Set olSMTPFailedFolder = OpenMAPIFolder("\MailboxOrFolderName\eeTesting\SMTP Failure")
    Set olItems = objInboxItems.Restrict("[Subject] = 'Delivery Status Notification (Failure)'")
    For intCounter = olItems.Count To 1 Step -1
        If olItems.Item(intCounter).Class = olMail Then
            If InStr(1, olItems.Item(intCounter).Body, "SMTP Failure") > 0 Then
                olItems.Item(intCounter).Move olSMTPFailedFolder
            End If
        End If
End Sub

'Credit where credit is due.
'The code below is not mine.  I found it somewhere on the internet but do
'not remember where or who the author is.  The original author(s) deserves all
'the credit for these functions.
Function OpenMAPIFolder(szPath)
    Dim app, ns, flr, szDir, i
    Set flr = Nothing
    Set app = CreateObject("Outlook.Application")
    If Left(szPath, Len("\")) = "\" Then
        szPath = Mid(szPath, Len("\") + 1)
        Set flr = app.ActiveExplorer.CurrentFolder
    End If
    While szPath <> ""
        i = InStr(szPath, "\")
        If i Then
            szDir = Left(szPath, i - 1)
            szPath = Mid(szPath, i + Len("\"))
            szDir = szPath
            szPath = ""
        End If
        If IsNothing(flr) Then
            Set ns = app.GetNamespace("MAPI")
            Set flr = ns.Folders(szDir)
            Set flr = flr.Folders(szDir)
        End If
    Set OpenMAPIFolder = flr
End Function

Function IsNothing(Obj)
  If TypeName(Obj) = "Nothing" Then
    IsNothing = True
    IsNothing = False
  End If
End Function
'Macro Ends Here
David LeeCommented:
Hi Activar,

I don't have any thoughts on the rules or why they don't work, but I can offer a macro that'll do what you've described.  Let me know if you're interested.

ActivarAuthor Commented:
I am certainly interested - I look forward to hearing from you.

ActivarAuthor Commented:
That is great BlueDevilFan! absolutely the right way to get to the root of this problem.

Thank you very much for the quick response!

Points are being increased and your answer accepted.
David LeeCommented:

No problem.  Glad to help out.  Let me know if there's anything else I can do.

One possible interesting addition to this would be to add code to delete contacts who can't be reached for certain reasons.  
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.