Set myOlApp = CreateObject("Outlook.Application")
Set myNameSpace = myOlApp.GetNameSpace("MAPI")
Set objContactsFolder = myNameSpace.GetDefaultFolder(10)
'objContactsFolder.Display



   ' Specify which contact folder to work with
'   Set objContactsFolder = Session.GetDefaultFolder(olFolderContacts)
   Set objContacts = objContactsFolder.Items

   ' Prompt for old and new company names
   'strOldCo = InputBox("Enter the old e-mail address (whole or partial address).")
   strOldCo = "abac.peachnet.edu"
   'strNewCo = InputBox("Enter the new e-mail address (whole or partial address).")
   strNewCo = "abac.edu"

   MsgBox ("Changing e-mail addresses containing abac.peachnet.edu to abac.edu.")
   MsgBox ("When prompted for allowing access to Outlook, respond with 10 minutes, Allow, Yes.")
   
   iCount = 0
   
   respond = MsgBox("Begin Updating e-mail addresses?", vbOKCancel)
   If respond = 2 Then
      MsgBox "Exiting without updating contacts."
   Else

   ' Process the changes
   For Each objContact In objContacts
      If TypeName(objContact) = "ContactItem" Then
            If InStr(1, objContact.Email1Address, strOldCo) > 1 Then
               objContact.Email1Address = Replace(objContact.Email1Address, strOldCo, strNewCo)
               objContact.Save
               iCount = iCount + 1
            End If
            If InStr(1, objContact.Email2Address, strOldCo) > 1 Then
               objContact.Email2Address = Replace(objContact.Email2Address, strOldCo, strNewCo)
               objContact.Save
               iCount = iCount + 1
            End If
            If InStr(1, objContact.Email2Address, strOldCo) > 1 Then
               objContact.Email3Address = Replace(objContact.Email3Address, strOldCo, strNewCo)
               objContact.Save
               iCount = iCount + 1
            End If
      End If
   Next
   
   MsgBox "Number of e-mail addresses updated:" & iCount
   End If
   

   ' Clean up
   Set objContact = Nothing
   Set objContacts = Nothing
   Set objContactsFolder = Nothing