Suggest Email Addresses

When you type letters into an address field (To, CC, BCC) of an email, Outlook suggests addresses you have already used. However, Outlook looks for the letters only at the beginning of the addresses. For instance, if you type 'vboffice', Outlook finds 'vboffice@domain' but not 'name@vboffice'.

This macro looks for a string within all email addresses in your default contacts folder. The position of the string within the address doesn't matter. Start the macro for instance by pressing ALT+F8. If you start it from an opened email, it will add the selected addresses to that email else it will create a new email.

In order to keep it simple, the found addresses will be listed in a MsgBox. You could, however, also add the code to your own MSForm and display the items in a listbox.

To get the code running you need to install the Redemption, which is free for private users. After the installation set a reference on the Redemption * Library via Tools/References.

  How to add macros to Outlook

Public Sub SuggestAddresses()
  Dim Session As Redemption.RDOSession
  Dim Folder As Redemption.RDOFolder
  Dim Items As Redemption.RDOItems
  Dim Filter As Redemption.TableFilter
  Dim ResContent As Redemption.RestrictionContent
  Dim ResOr As Redemption.RestrictionOr
  Dim Item As Redemption.RDOContactItem
  Dim CollAdr As VBA.Collection
  Dim obj As Object
  Dim Mail As Outlook.MailItem
  Dim Email1 As Long, Email2 As Long, Email3 As Long
  Dim i As Long, Index As Long
  Dim AdrType As Long
  Dim IsNewMail As Boolean
  Dim FindString As String
  Dim Adr As String, Msg As String
  Dim UseAdr() As String
  
  FindString = InputBox("Suchbegriff:")
  If Len(FindString) = 0 Then Exit Sub
  
  Set Session = CreateObject("redemption.rdosession")
  Session.MAPIOBJECT = Application.Session.MAPIOBJECT
  Set Folder = Session.GetDefaultFolder(olFolderContacts)
  Set Items = Folder.Items
  
  If Items.Count Then
    Set Item = Items(1)
    Email1 = Item.GetIDsFromNames("{00062004-0000-0000-C000-000000000046}", &H8083) Or &H1E
    Email2 = Item.GetIDsFromNames("{00062004-0000-0000-C000-000000000046}", &H8093) Or &H1E
    Email3 = Item.GetIDsFromNames("{00062004-0000-0000-C000-000000000046}", &H80A3) Or &H1E
    
    Set Filter = Items.MAPITable.Filter
    Filter.Clear
    
    Set ResOr = Filter.SetKind(RES_OR)
    
    Set ResContent = ResOr.Add(RES_CONTENT)
    ResContent.ulPropTag = Email1
    ResContent.lpProp = FindString
    ResContent.ulFuzzyLevel = FL_IGNORECASE Or FL_SUBSTRING
    
    Set ResContent = ResOr.Add(RES_CONTENT)
    ResContent.ulPropTag = Email2
    ResContent.lpProp = FindString
    ResContent.ulFuzzyLevel = FL_IGNORECASE Or FL_SUBSTRING
    
    Set ResContent = ResOr.Add(RES_CONTENT)
    ResContent.ulPropTag = Email3
    ResContent.lpProp = FindString
    ResContent.ulFuzzyLevel = FL_IGNORECASE Or FL_SUBSTRING
    
    Filter.Restrict
    
    If Items.Count Then
      Set CollAdr = New VBA.Collection
      Index = 0
      Msg = ""
      Items.Sort "FileAs", False
      
      For Each Item In Items
        Adr = ""
        If Len(Item.Email1Address) Then
          Index = Index + 1
          Adr = Index & ": " & Item.Email1Address & vbCrLf & vbTab
          CollAdr.Add Item.Email1Address
        End If
        If Len(Item.Email2Address) Then
          Index = Index + 1
          Adr = Adr & Index & ": " & Item.Email2Address & vbCrLf & vbTab
          CollAdr.Add Item.Email2Address
        End If
        If Len(Item.Email3Address) Then
          Index = Index + 1
          Adr = Adr & Index & ": " & Item.Email3Address & vbCrLf
          CollAdr.Add Item.Email3Address
        End If
        If Len(Adr) Then
          Msg = Msg & vbCrLf & Item.FileAs & vbCrLf & vbTab & Adr
        End If
      Next
      
      If CollAdr.Count Then
        Msg = "Enter a number for the address (use the semi-kolon to enter multiple numbers):" & vbCrLf & Msg
        FindString = InputBox(Msg, Items.Count & " contacts found with '" & FindString & "' in an address")
        If Len(FindString) = 0 Then Exit Sub
        FindString = Replace(FindString, ",", ";")
        UseAdr = Split(FindString, ";")
        
        Msg = "Enter a number for the address type:" & vbCrLf
        Msg = Msg & "1 = AN" & vbCrLf
        Msg = Msg & "2 = CC" & vbCrLf
        Msg = Msg & "3 = BCC"
        AdrType = Val(InputBox(Msg, , 1))
        If AdrType = 0 Then Exit Sub
        
        If TypeOf Application.ActiveWindow Is Outlook.Inspector Then
          Set obj = Application.ActiveInspector.CurrentItem
          If TypeOf obj Is Outlook.MailItem Then
            Set Mail = obj
          End If
        End If
        If Mail Is Nothing Then
          Set Mail = Application.CreateItem(olMailItem)
          IsNewMail = True
        End If
        
        Adr = ""
        For i = 0 To UBound(UseAdr)
          Index = Val(UseAdr(i))
          If Index > 0 And Index <= CollAdr.Count Then
            Adr = Adr & CollAdr(Index) & "; "
          End If
        Next
        
        Select Case AdrType
        Case 2: Mail.cc = Adr
        Case 3: Mail.BCC = Adr
        Case Else: Mail.To = Adr
        End Select
        
        If IsNewMail Then
          Mail.Display
        End If
        Mail.Recipients.ResolveAll
      End If
    End If
  End If
  If Mail Is Nothing Then
    MsgBox "The phrase '" & FindString & "' was not found", vbInformation
  End If
End Sub