Filtering undeliverable spam return messages

[mdmackillop]

It seems my office email address has been hijacked and is being used to send spam. This results in hundreds of "Undeliverable" and similar responses. I've set up a rule to divert these to a folder, but I would like to be able to check for valid items.
Is it possible to check each message header against a list of valid email addresses (either my address book or a txt file, whichever is easier) and move valid messages into another folder?
Any help greatly appreciated
MD

[mdmackillop]

First attempt

Sub KillSpamReturns()
'Needs a reference to Microsoft Scripting Runtime
Dim olSession As Outlook.Application, olNamespace As NameSpace
Dim olReturns As Outlook.MAPIFolder, olNoDel As Outlook.MAPIFolder
Dim olItem As MailItem
Dim olDict As Dictionary
Dim Test As Boolean

'http://msdn2.microsoft.com/en-us/library/bb176395.aspx
'and
'http://blogs.technet.com/kclemson/archive/2006/10/27/
'quickly-view-the-internet-headers-of-a-message-in-outlook.aspx

Dim MessageHeader As String
Dim dataObject As MSForms.dataObject
Dim dic As Object, d
'Get list of email addresses
Set dic = CreateObject("Scripting.Dictionary")
Open "C:\AAA\Addr.txt" For Input As #1 ' Open file
Do While Not EOF(1) ' Check for end of file.
Line Input #1, inputdata ' Read line of data.
dic.Add inputdata, inputdata ' Add name to dictionary
Loop
Close #1 ' Close file.
Const PR_TRANSPORT_MESSAGE_HEADERS = "http://schemas.microsoft.com/mapi/proptag/0x007D001E"
Set olSession = New Outlook.Application
Set olNamespace = olSession.GetNamespace("MAPI")
On Error Resume Next

'Custom folders to handle receipts
Set olReturns = olNamespace.GetDefaultFolder(olFolderInbox).Folders("Returns")
Set olNoDel = olNamespace.GetDefaultFolder(olFolderInbox).Folders("Undelivered")

'Loop through each receipt
For Each olItem In olReturns.Items
If TypeName(olItem) = "MailItem" Then
MessageHeader = olItem.PropertyAccessor.GetProperty(PR_TRANSPORT_MESSAGE_HEADERS)
If MessageHeader <> "" Then
Test = True
'Loop through each address
For Each d In dic
If InStr(1, MessageHeader, d) > 0 Then
'Move item if address found and exit loop
olItem.Move olNoDel
Test = False
Exit For
End If
Next
'Delete email if address not found
If Test = True Then olItem.Delete
End If
End If
Next
Set olDict = Nothing
Set olSession = Nothing
End Sub