Solved

Outlook 2013 Macro - Update Contacts process

Posted on 2014-09-10
9
331 Views
Last Modified: 2014-09-16
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
0
Comment
Question by:rogerdjr
  • 5
  • 2
  • 2
9 Comments
 
LVL 13

Expert Comment

by:Alexei Kuznetsov
ID: 40316552
I suggest you to look at the Folder.GetTable() method. It is orders of magnitude faster than iterating Items collection.
0
 

Author Comment

by:rogerdjr
ID: 40322360
Good idea - I will re-configure and try it out this week.
0
 

Author Comment

by:rogerdjr
ID: 40323289
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
 
LVL 13

Expert Comment

by:Alexei Kuznetsov
ID: 40324979
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
6 Surprising Benefits of Threat Intelligence

All sorts of threat intelligence is available on the web. Intelligence you can learn from, and use to anticipate and prepare for future attacks.

 

Author Comment

by:rogerdjr
ID: 40325625
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
 

Author Comment

by:rogerdjr
ID: 40326002
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
 
LVL 76

Accepted Solution

by:
David Lee earned 500 total points
ID: 40326464
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
 

Author Closing Comment

by:rogerdjr
ID: 40326868
An excellent solution thank you very much

Fast and efficient and a good learning experience for me

Thanks
0
 
LVL 76

Expert Comment

by:David Lee
ID: 40327069
You're welcome!
0

Featured Post

Maximize Your Threat Intelligence Reporting

Reporting is one of the most important and least talked about aspects of a world-class threat intelligence program. Here’s how to do it right.

Join & Write a Comment

Suggested Solutions

Title # Comments Views Activity
Outlook 2010 Calendar 5 40
outlook, calendar 21 39
Outlook for Mac Meeting Rooms 2 23
OUtlook missing email alert 9 15
Create high volume marketing opportunities using email signatures with these top 10 DOs and DON'Ts of email signature marketing.
Resolve Outlook connectivity issues after moving mailbox to new Exchange 2016 server
Show developers how to use a criteria form to limit the data that appears on an Access report. It is a common requirement that users can specify the criteria for a report at runtime. The easiest way to accomplish this is using a criteria form that a…
This lesson covers basic error handling code in Microsoft Excel using VBA. This is the first lesson in a 3-part series that uses code to loop through an Excel spreadsheet in VBA and then fix errors, taking advantage of error handling code. This l…

707 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

15 Experts available now in Live!

Get 1:1 Help Now