Delete Outlook Address Book Records with Undeliverable Email Addre

[Guest]

I am a contractor and need to send out emails to agencies when I'm looking
for a new contract. There is always a proportion of 'dead' address book
records where contacts have moved on or the agency has closed. I have to
delete those useless records and can do it with the following code. It
illustrates the use of Regexp to locate the email address in the body of the
message:

Public Sub old_email_addr()
Dim messages As Variant, olContact As ContactItem, message As Object
Dim myFolder As MAPIFolder, text As String, num As Double
Dim counter As Double, x As Double, Email As String, flub As Variant
Dim a() As String, reg As RegExp, myOlApp As Object
Dim matches As MatchCollection, myNameSpace As NameSpace
Dim addr As String, olAgencies As Outlook.MAPIFolder, objContact As
ContactItem

'a() will hold the final list of faulty email addresses
'matches will hold the array of email addresses in all messages
Set myOlApp = CreateObject("Outlook.Application")
Set myNameSpace = myOlApp.GetNamespace("MAPI")
'Set myFolder = myNameSpace.PickFolder - you could select which folder
Set myFolder =
myNameSpace.GetDefaultFolder(olFolderInbox).Folders("Undeliverables")
'I send all "undeliverable" messages to this folder
Set olAgencies =
myNameSpace.GetDefaultFolder(olFolderContacts).Folders("Agencies")
'Agencies is the address book to be pruned
Set messages = myFolder.Items
Set reg = New RegExp 'Set up a new Regular Expression search
reg.Pattern = "\b[A-Z0-9._%-]+@[A-Z0-9.-]+\.[A-Z]{2,4}\b"
'Regular Expression pattern for email address
reg.Global = True
reg.IgnoreCase = True
reg.Multiline = True
counter = 0

'Fill up the array with incorrect email address
For Each Item In messages
text = Item.Body
'This is the body text from the email which will contain the lost address
Set matches = reg.Execute(text)
'Search for all email addresses in the body of this email and copy them
into matches
num = matches.Count
ReDim Preserve a(counter + num) 'Expand the array as required
For x = 0 To num - 1
'Copy these email addresses into the array
Email = matches.Item(x)
a(counter + x) = Email
Next
counter = counter + num
Next

'Now the array of email addresses is ready, match them to their Agencies
address book entries
'and delete the records
For x = 0 To UBound(a)
addr = a(x)
Set objContact = olAgencies.Items.Find("[Email1Address] = " & Chr(34) &
addr & Chr(34))
'Find the record that contains the bad email address
If Not TypeName(objContact) = "Nothing" Then objContact.Delete
'If the record is found, delete it
Next
End Sub

Regexp is enabled by going to Tools/References in your vba project and
ticking VBScript Regular Expressions 5.5 and OK. This works well in Outlook
2003 and should work with earlier versions.