How to Quickly Create Outlook Contacts for All Email Addresses Occurring in a Word Document

This article will share you a method to quickly extract all the email addresses from a Word document and then create according contacts for them in your Outlook.

In my previous article – “How to Quickly Send an Outlook Email to All Email Addresses Occurring in Several Word documents”, you can easily learn to send an email to the email addresses in Word documents. Similarly, maybe for the future convenience, you may wish to create the corresponding contacts for these email addresses. Here we will guide you how to realize it in quick time.

Create Contacts for All Email Addresses Occurring in a Word document

1. To start with, launch your Outlook program.
2. Then in the main Outlook screen, you can press “Alt + F11” key buttons.
3. Next you’ll get access to Outlook VBA editor window, in which you ought to open a module that is not in use.
4. Subsequently, you need to copy the following VBA code into this module.

Sub AddEmailAddresses_OutlookContacts()
    Dim objWordApp As Word.Application
    Dim objWordDocument As Word.Document
    Dim strEmailAddress, strFullName As String
    Dim objContacts As Outlook.Items
    Dim i As Long
    Dim strFilter As String
    Dim objFoundContact As Outlook.ContactItem
    Dim objNewContact As Outlook.ContactItem
 
    Set objWordApp = CreateObject("Word.Application")
    objWordApp.Visible = True
    'Change the path to the source Word document
    Set objWordDocument = objWordApp.Documents.Open("E:\Outlook\DataNumen Outlook Repair.docx")
 
    'Find the email addresses via wildcards
    With objWordApp.Selection.Find
         .Text = "[A-z,0-9]{1,}\@[A-z,0-9,.]{1,}"
         .MatchWildcards = True
         .Execute
    End With
 
    While objWordApp.Selection.Find.Found
          'Get the email address
          strEmailAddress = objWordApp.Selection.Text
          'Get the name from the email address
          strFullName = Split(strEmailAddress, "@")(0)
 
          Set objContacts = Application.Session.GetDefaultFolder(olFolderContacts).Items
 
          'Check if the email address has been in your Contacts folder
          For i = 1 To 3
              strFilter = "[Email" & i & "Address] = " & strEmailAddress
              Set objFoundContact = objContacts.Find(strFilter)
              If Not objFoundContact Is Nothing Then
                 Exit For
              End If
          Next i
 
          'If email addresses are not in the default Contacts folder
          If objFoundContact Is Nothing Then
 
             'Create a new Outlook Contact
             Set objNewContact = Application.CreateItem(olContactItem)
 
             'Input the contact email address and full name
             With objNewContact
                  .Email1Address = strEmailAddress
                  .FullName = strFullName
                  .Display
                  '.Save ==> Save the contact
             End With
          End If
 
          objWordApp.Selection.Find.Execute
     Wend
 
    'Close the Word document
    objWordDocument.Close
    'Exit Word Application
    objWordApp.Quit
End Sub

5. After that, you have to ensure that macros are enabled in your Outlook in the “Macro Settings”.
6. Eventually, you can have a try. In the new macro window, press F5 key button to run this macro.
7. Then, Outlook will automatically create the contacts for the email addresses which haven’t existed in your default Contacts folder.

Keep a Formidable Fix Tool Nearby

Though Outlook is loaded with quantities of functions, it is still vulnerable to lots of factors, such as human improper operations, virus infections and so on. Hence, aside from making regular backups and relying on inbox repair tool, you’d better also keep another remarkable and reliable PST fix tool nearby, like DataNumen Outlook Repair. It can scan and restore Outlook data with utmost ease.

Author Introduction:

Shirley Zhang is a data recovery expert in DataNumen, Inc., which is the world leader in data recovery technologies, including mdf recovery and outlook repair software products. For more information visit www.datanumen.com