Outlook 2013 Macro - Update Contacts process

I created this code to page through emails and update the user2 field of the associated contact with the delivery status - basically to identify contacts with inactive email addresses.

the return receipt info has the recipient's email address in the body of the return receipt email

It works fine and when there are just a few emails, paging through each email and then paging all 6,000 contacts in my address book to find the associated contact.

When there are a lot of emails this is a very time consuming process and might work faster if there was a "find Process" rather than paging through each contact.

I'd appreciate any suggestions that you could offer.

Attached is a typical "return receipt email" though content can vary, in each case the email address is in the body of the email I am searching.

Thanks

-------------------------------------------------------

Sub UpdateContactBasedOnEmailDeliveryData()

    Dim mai As MailItem
    Dim UpdtCount As Integer, UpdtCount1 As Integer
   
    Dim oOlApp As Outlook.Application
    Dim objNmSpc As NameSpace
    Dim ofldr As Object
    Dim ContFldr As Object
   
    Dim olObject As Object
    Dim olContact As Outlook.ContactItem
   
    Dim StrWhere As String

    Set oOlApp = Outlook.Application
    Set objNmSpc = oOlApp.GetNamespace("MAPI")
   
    MsgBox "Select Email Folder"
    Set ofldr = objNmSpc.PickFolder
   
    MsgBox "Select Contacts Folder"
    Set ContFldr = objNmSpc.PickFolder

    MsgBox "Email Folder - " & ofldr & vbNewLine & "Contacts - " & ContFldr

    UpdtCount = 1
   
        For Each mai In ofldr.Items
            If mai.Class = olMail Then
                With mai
               
                UpdtCount1 = 1
                    For Each olObject In ContFldr.Items
                   
                        If TypeName(olObject) = "ContactItem" Then
                            Set olContact = olObject
                           
                            If InStr(1, .Body, olContact.Email1Address) > 0 And Len(olContact.Email1Address) > 0 And InStr(1, .Subject, "deliver", vbTextCompare) Then
                                olContact.User2 = .Subject
                                olContact.Save
                            End If

                        End If
                       
                        UserForm1.TextBox1 = "Email " & UpdtCount & " " & .Subject
                        UserForm1.TextBox2 = "Contact " & UpdtCount1 & " " & olContact.FileAs
                        UserForm1.Show vbModeless
                        DoEvents
                       
                        UpdtCount1 = UpdtCount1 + 1
                    Next
                                                   
                End With
            End If
                       
            UpdtCount = UpdtCount + 1
        Next
       
        Unload UserForm1
       
        MsgBox "Macro Complete"

End Sub
Delivered-Facility-Condition-Assessments
rogerdjrAsked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Alexei KuznetsovMicrosoft Outlook MVPCommented:
I suggest you to look at the Folder.GetTable() method. It is orders of magnitude faster than iterating Items collection.
0
rogerdjrAuthor Commented:
Good idea - I will re-configure and try it out this week.
0
rogerdjrAuthor Commented:
Tried this code and can't seem to access the contents of the contacts in the line             MsgBox .FirstName & vbNewLine & .LastName & vbNewLine & .Email1Address

Get the attached error message - searched the internet for a reference that might help with no success.

Sub zzTestFolderGetTableMethod()
    'Declarations
    Dim Filter As String
    Dim oRow As Outlook.Row
    Dim oTable As Outlook.Table
   
    Dim oOlApp As Outlook.Application
    Dim objNmSpc As NameSpace
    Dim ContFldr As Object
   
    Set oOlApp = Outlook.Application
    Set objNmSpc = oOlApp.GetNamespace("MAPI")
   
    MsgBox objNmSpc.GetDefaultFolder(olFolderContacts).FolderPath
    Set ContFldr = objNmSpc.GetDefaultFolder(olFolderContacts)
   
    'Define Filter to obtain items last modified after May 1, 2005
    Filter = "[User1] = '09-04-2014 - Facility Condition Assessments'"
    'Restrict with Filter
    Set oTable = ContFldr.GetTable(Filter)
 
    'Enumerate the table using test for EndOfTable
    Do Until (oTable.EndOfTable)
        Set oRow = oTable.GetNextRow()
        With oTable
            MsgBox .FirstName & vbNewLine & .LastName & vbNewLine & .Email1Address
        End With
    Loop
End Sub
zzTestFolderGetTableMethod---error.pdf
0
Ultimate Tool Kit for Technology Solution Provider

Broken down into practical pointers and step-by-step instructions, the IT Service Excellence Tool Kit delivers expert advice for technology solution providers. Get your free copy now.

Alexei KuznetsovMicrosoft Outlook MVPCommented:
This is not the way it works. You need to explicitly provide the required fields using oTable.Columns. See How to: Filter and Efficiently Enumerate Items in a Folder MSDN article for details and sample.
0
rogerdjrAuthor Commented:
Thanks - I read the article and it was helpful - it appears that the table is read only

The way my original code worked is to:
1) Select an return receipt email with an email address embedded in the text of the body of the email
2) Page through each contact to see if the contact's email address is found in the body of the selected email (using the instr() function)
3) If the contact address is found I would then update the User2. field with the selected email's subject text.

The idea is that when I do an eblast, a bunch of the emails are returned as received and read and a bunch are rejected for one reason or another or are simple deleted and not read. This process would help me evaluate the return emails and fix any problems that are found.

I may be able to use the filter to narrow the search of the contacts decreasing the number with the User2 as blank and doing a subroutine to open and edit each contact. That will take some thought so I'll spend a little time (between projects) this week to sort it out.

Thanks
0
rogerdjrAuthor Commented:
Update

a very simple process where I'd like to apply a filter and update the contact user4 field for only those existing contacts have an entry in the user4 field, I tried to modify to filter using the Folder.GetTable Method (Outlook) but I can't figure out how to edit the contact row

Sub z09_02_2014_UpdateContact()
    Dim olApp As Outlook.Application
    Dim olNS As Outlook.Namespace
    Dim olFolder As Outlook.MAPIFolder

    Set olApp = Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")
    Set olFolder = olNS.PickFolder

    Dim olObject As Object
    Dim olContact As Outlook.ContactItem
   
    Dim ContactNo As Integer

ContactNo = 1
    For Each olObject In olFolder.Items

        If TypeName(olObject) = "ContactItem" Then
            Set olContact = olObject
                   
            olContact.User4 = ""
            olContact.Save
           
            UserForm1.TextBox1 = "Clearing User4 - All Contacts - Contact # " & ContactNo
            UserForm1.Show vbModeless
            DoEvents
        End If
        ContactNo = ContactNo + 1
    Next
end sub
0
David LeeCommented:
Hi, rogerdjr.

The approach used in the code you initially posted is doing things in kind of a backwards fashion.  It's reading through every contact checking to see if that contact's email address is in the message.  It's more efficient to read a message, find the addresses in the message, then use Outlook's built in Find method to locate a contact with a matching address.  That's the approach I used below.  This code reads all the messages in the currently selected folder.  For each message, the code uses a regular expression to parse the email addresses out of the message body.  For each address it finds, it then searches the Contacts folder using the Find method looking for a matching email address.  If it finds one, then it updates the contact's User2 field by setting the field to the subject of the current message.

Sub UpdateContact()
    Dim olkMsg As Object, _
        olkFld As Outlook.Folder, _
        olkCon As Outlook.ContactItem, _
        arrAdr As Variant, _
        varAdr As Variant
    Set olkFld = Session.GetDefaultFolder(olFolderContacts)
    For Each olkMsg In Application.ActiveExplorer.CurrentFolder.Items
        If olkMsg.Class = olMail Then
            arrAdr = Split(FindString(olkMsg.Body, "\b[A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}\b"), "|")
            For Each varAdr In arrAdr
                Set olkCon = olkFld.Items.Find("[Email1Address] = '" & varAdr & "'")
                If TypeName(olkCon) = "ContactItem" Then
                    olkCon.User2 = olkMsg.Subject
                    olkCon.Save
                End If
            Next
        End If
    Next
    Set olkCon = Nothing
    Set olkFld = Nothing
    Set olkMsg = Nothing
End Sub

Private Function FindString(strText As String, strFind As String) As String
    Dim objRegEx As Object, colMatches As Object, objMatch As Object
    Set objRegEx = CreateObject("VBscript.RegExp")
    With objRegEx
        .IgnoreCase = True
        .Global = True
        .Pattern = strFind
        Set colMatches = .Execute(strText)
    End With
    For Each objMatch In colMatches
        FindString = FindString & objMatch.value & "|"
    Next
    If Len(FindString) > 0 Then
        FindString = Left(FindString, Len(FindString) - 1)
    End If
    Set objRegEx = Nothing
    Set colMatches = Nothing
    Set objMatch = Nothing
End Function

Open in new window

0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
rogerdjrAuthor Commented:
An excellent solution thank you very much

Fast and efficient and a good learning experience for me

Thanks
0
David LeeCommented:
You're welcome!
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Outlook

From novice to tech pro — start learning today.

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.