none
Outlook 2007 Macro Search Contacts RRS feed

  • Question

  • Through someone else technically, I have this code that when I receive an email message, if the message area has an email address in it, this code recognizes the first email address in the body field of the message, and searches automatically for the contact in my list of contacts that has the email address, and it opens up the contact.   The purposes of this is sometimes I send and an email message and receive a message back that a certain email was not delivered, and in the email I receive back, it shows that email address not delivered, so I can find the contact that is a part of that.

    But the original code only searches the folder Contacts....not all other sub folders and sub sub folders of the Contact folder.   So I changed the one line which is " Set myContacts = Session.GetDefaultFolder(olFolderContacts).Items" to a specifc sub sub folder using the following line:  "Set myContacts = Session.GetDefaultFolder(olFolderContacts).Folders("Test").Folders("Sub Test").Folders("Sub Sub Test").Items", and it searches that particular sub sub folder.

    So does anyone know quickly what to change so that it searches all Contacts, sub folders and sub sub folders?  And if the way to do it, is I need to add to it each sub folder and sub sub folder name, I would like to know how to do that.  Thanks very much and here is the full code.

    Sub GetValueUsingRegEx32()
        Dim obj As Object
        Dim Selection As Selection
        Dim olMail As Object 'Outlook.MailItem
        Dim Reg1 As Object
        Dim M1 As Object
        Dim M As Object
        Dim strAddress As String
        Dim myContacts As Items
        Dim myItem As contactItem
     
          
        Set Selection = Application.ActiveExplorer.Selection
        Set myContacts = Session.GetDefaultFolder(olFolderContacts).Folders("Test").Folders("Sub Test 2").Folders("Sub Sub Test 2").Items
     
      For Each obj In Selection
        Set olMail = obj
     
       Set Reg1 = CreateObject("VBScript.RegExp")
         With Reg1
           .Pattern = "(([\w-\.]*\@[\w-\.]*)\s*)"
           .IgnoreCase = True
           .Global = False
        End With
        
        If Reg1.TEst(olMail.Body) Then
         
            Set M1 = Reg1.Execute(olMail.Body)
            For Each M In M1
                 strAddress = M.SubMatches(1)
                Debug.Print strAddress
                
            Set myItem = myContacts.Find("[Email1Address]=" & strAddress)
                   
                myItem.Display
                 
           Next
           
        End If
    Next
    End Sub

    Friday, May 2, 2014 9:59 PM

Answers

  • To All:

    This is the code that does what I asked for:


    Dim strAddress As String
    Sub GetValueUsingRegEx3()
    Dim obj As Object
    Dim Selection As Selection
    Dim olMail As Object 'Outlook.MailItem
    Dim Reg1 As Object
    Dim M1 As Object
    Dim M As Object
     
    Set objNS = Application.GetNamespace("MAPI")
    Set Selection = Application.ActiveExplorer.Selection
     
    For Each obj In Selection
    Set olMail = obj
    Set Reg1 = CreateObject("VBScript.RegExp")
    With Reg1
    .Pattern = "(([\w-\.]*@[\w-\.]*)\s*)"
    .IgnoreCase = True
    .Global = False
    End With
     
    If Reg1.test(olMail.Body) Then
     
    Set M1 = Reg1.Execute(olMail.Body)
    For Each M In M1
    strAddress = M.SubMatches(1)
    Debug.Print strAddress & " " & Time
    processFolder (objNS.GetDefaultFolder(olFolderContacts))
     
    Next
     
    End If
    Next
    End Sub
     
    Private Sub processFolder(ByVal oParent As Outlook.MAPIFolder)
    Dim oFolder As Outlook.MAPIFolder
    Dim oContact As Outlook.ContactItem
    On Error Resume Next
    For Each oContact In oParent.Items
      If oContact.Email1Address = strAddress Then
        oContact.Display
      End If
    Next
    If (oParent.Folders.Count > 0) Then
    For Each oFolder In oParent.Folders
    Call processFolder(oFolder)
    Next
    End If
    End Sub

    Wednesday, May 21, 2014 5:40 PM

All replies

  • Hello Imseaz,

    The Restrict and Find/FindNext methods of the Items class allows to search only in a particular Items collection. You can read more about them in them in the following articles, a sample code in C# and VB.NET is included:

    How To: Use Find and FindNext to retrieve Outlook Contact items

    How To: Retrieve Outlook Contact items using Restrict method

    The AdvancedSearch method of the Application class allows to search in subfolders (see the third parameter named SearchSubFolders). You can find the method described in depth and a sample code in C# and VB.NET in the Advanced search in Outlook programmatically: C#, VB.NET article.

    Saturday, May 3, 2014 5:58 AM
  • Thanks very much.  As I repeat, I am not on technical side and I need someone to show me what to change to my code I got from someone else.
    Saturday, May 3, 2014 4:42 PM
  • Imseaz,

    The articles I mentioned in my previous post provide a sample code in C# and VB.NET. See the Advanced search in Outlook programmatically: C#, VB.NET article.

    Saturday, May 3, 2014 5:25 PM
  • That does not show me how to do what I am trying to do...if you know how to do it, change by code or give me anew code, that would be nice, as I am not on the technical side of things.
    Saturday, May 3, 2014 7:02 PM
  • Imseaz,

    The current forum is for developers. To get a ready-made solution you need to hire a developer. Try asking such questions on the freelance-related web sites instead.

    Sunday, May 4, 2014 12:07 PM
  • Please tell me what freelance related web sites are
    Sunday, May 4, 2014 2:32 PM
  • Try using a search engine, don't want to advertise web sites there.
    Monday, May 5, 2014 8:35 AM
  • Hi Imseaz,

    >>So does anyone know quickly what to change so that it searches all Contacts, sub folders and sub sub folders? <<

    From your description, I think you could use recursion.

    Here is a sample I changed from yours:

    Sub GetValueUsingRegEx32()
        Dim obj As Object
        Dim Selection As Selection
        Dim olMail As Object 'Outlook.MailItem
        Dim Reg1 As Object
        Dim M1 As Object
        Dim M As Object
        Dim strAddress As String
        Dim myContacts As Items
        Dim myItem As ContactItem
        Set Selection = Application.ActiveExplorer.Selection
        Set objNS = Application.GetNamespace("MAPI")
        processFolder (objNS.GetDefaultFolder(olFolderContacts))
    End Sub
    
    Private Sub processFolder(ByVal oParent As Outlook.MAPIFolder)
        Dim oFolder As Outlook.MAPIFolder
        Dim oContact As Outlook.ContactItem
    
        For Each oContact In oParent.Items
            'do what you want to do
        Next
    
        If (oParent.Folders.Count > 0) Then
            For Each oFolder In oParent.Folders
                Call processFolder(oFolder)
            Next
        End If
    End Sub

    It would loop all contact items and subfolders under Contacts.

    Hope this helps.


    We are trying to better understand customer views on social support experience, so your participation in this interview project would be greatly appreciated if you have time. Thanks for helping make community forums a great place.
    Click HERE to participate the survey.

    Monday, May 5, 2014 8:55 AM
    Moderator
  • When I run it, it does not do it, and the following code line turns yellow:


        For Each oContact In oParent.Items

    Monday, May 5, 2014 6:34 PM
  • Hi Imseaz,

    What is the issue message from Outlook?

    As I tested in Outlook 2007, the code works fine for me and will loop all contacts under folders.

    Here is my contact:

    Every contact would be found.


    We are trying to better understand customer views on social support experience, so your participation in this interview project would be greatly appreciated if you have time. Thanks for helping make community forums a great place.
    Click HERE to participate the survey.

    Tuesday, May 6, 2014 7:09 AM
    Moderator
  • Thanks very much....I guess I don't know what to run as it looks like two macros...so what is the best way to run it please?
    Tuesday, May 6, 2014 5:35 PM
  • I want it to display the contact that has the email address in the note field of the email I receive.

    So in the line :  For Each oContact In oParent.Items, after that I add oContact,Display, it just opens up all contacts.......so how do I have it just open up the contact  that has the email address in the note field of the email I receive?

    Tuesday, May 6, 2014 9:06 PM
  • Hi Imseaz,

    >>I guess I don't know what to run as it looks like two macros...so what is the best way to run it please?<<

    Run the macro named "GetValueUsingRegEx32", it would call the second macro.

    >>so how do I have it just open up the contact  that has the email address in the note field of the email I receive?<<

    What do you mean by note field of an email?

    Do you want to find a specified contact and open it according to current selected email?

    If so, you need to find the match condition between MailItem and ContactItem.

    Here is the code I changed:

    Sub GetValueUsingRegEx32()
        Dim obj As Object
        Dim Selection As Selection
        Dim olMail As Object 'Outlook.MailItem
        Dim Reg1 As Object
        Dim M1 As Object
        Dim M As Object
        Dim strAddress As String
        Dim myContacts As Items
        Dim myItem As ContactItem
        Set Selection = Application.ActiveExplorer.Selection
        Set objNS = Application.GetNamespace("MAPI")
        Call processFolder(objNS.GetDefaultFolder(olFolderContacts), Selection.Item(1).SenderName) 'Selection.Item(1).ReceivedByName Selection.Item(1).CC
    End Sub
    
    Private Sub processFolder(ByVal oParent As Outlook.MAPIFolder, ByVal displayname As String)
        Dim oFolder As Outlook.MAPIFolder
        Dim oContact As Outlook.ContactItem
        Dim found As Boolean
        found = False
        For Each oContact In oParent.Items
            'do what you want to do
            If displayname = oContact.Email1DisplayName Then
                oContact.Display
                found = True
                Exit For
            End If
        Next
        If found = True Then Exit Sub
        If (oParent.Folders.Count > 0) Then
            For Each oFolder In oParent.Folders
                Call processFolder(oFolder, displayname)
                If found = True Then Exit Sub
            Next
        End If
    End Sub

    I add a new parameter to match the display name of contact.

    Hope this helps.


    We are trying to better understand customer views on social support experience, so your participation in this interview project would be greatly appreciated if you have time. Thanks for helping make community forums a great place.
    Click HERE to participate the survey.

    Thursday, May 8, 2014 6:45 AM
    Moderator
  • Thank you. As I mentioned earlier , I get an email message back from Microsoft that the email I sent was not delivered to the email address that the Microsoft email shows in the message back to me. So I want to just select the email I got back from Microsoft and the macro I run opens the contact that has the email address that Microsoft shows to me in their message that it was not delivered to that message. The code i posted at the top recognizes the email address in the email message to me but does not search the contacts in all sub, sub sub, and sub sub sub contact folders.
    • Edited by lmseaz Thursday, May 8, 2014 7:40 AM
    Thursday, May 8, 2014 7:10 AM
  • Update please?
    Saturday, May 10, 2014 1:45 AM
  • To All:

    This is the code that does what I asked for:


    Dim strAddress As String
    Sub GetValueUsingRegEx3()
    Dim obj As Object
    Dim Selection As Selection
    Dim olMail As Object 'Outlook.MailItem
    Dim Reg1 As Object
    Dim M1 As Object
    Dim M As Object
     
    Set objNS = Application.GetNamespace("MAPI")
    Set Selection = Application.ActiveExplorer.Selection
     
    For Each obj In Selection
    Set olMail = obj
    Set Reg1 = CreateObject("VBScript.RegExp")
    With Reg1
    .Pattern = "(([\w-\.]*@[\w-\.]*)\s*)"
    .IgnoreCase = True
    .Global = False
    End With
     
    If Reg1.test(olMail.Body) Then
     
    Set M1 = Reg1.Execute(olMail.Body)
    For Each M In M1
    strAddress = M.SubMatches(1)
    Debug.Print strAddress & " " & Time
    processFolder (objNS.GetDefaultFolder(olFolderContacts))
     
    Next
     
    End If
    Next
    End Sub
     
    Private Sub processFolder(ByVal oParent As Outlook.MAPIFolder)
    Dim oFolder As Outlook.MAPIFolder
    Dim oContact As Outlook.ContactItem
    On Error Resume Next
    For Each oContact In oParent.Items
      If oContact.Email1Address = strAddress Then
        oContact.Display
      End If
    Next
    If (oParent.Folders.Count > 0) Then
    For Each oFolder In oParent.Folders
    Call processFolder(oFolder)
    Next
    End If
    End Sub

    Wednesday, May 21, 2014 5:40 PM