Outlook Macro to modify Contacts

[thockman]

Here is a simple macro to clear the business phone number in contacts if they meet certain criteria.

Code: Select all

Sub ChangePhone()

   Dim objContactsFolder As Outlook.MAPIFolder
   Dim objContacts As Outlook.Items
   Dim objContact As Object
   Dim iCount As Integer
   Dim strChanged As String
   
   ' Specify which contact folder to work with
   Set objContactsFolder = Session.GetDefaultFolder(olFolderContacts)
   Set objContacts = objContactsFolder.Items
   iCount = 0

   ' Process the changes
   For Each objContact In objContacts
      If TypeName(objContact) = "ContactItem" Then
        If InStr(objContact.BusinessTelephoneNumber, "913") And InStr(objContact.BusinessTelephoneNumber, "384") And InStr(objContact.BusinessTelephoneNumber, "1008") Then
            'MsgBox objContact.BusinessTelephoneNumber
            objContact.BusinessTelephoneNumber = ""
            objContact.Save
            strChanged = "yes"
        End If
        If InStr(objContact.Business2TelephoneNumber, "913") And InStr(objContact.Business2TelephoneNumber, "384") And InStr(objContact.Business2TelephoneNumber, "1008") Then
            'MsgBox objContact.BusinessTelephoneNumber
            objContact.Business2TelephoneNumber = ""
            objContact.Save
            strChanged = "yes"
        End If
      If strChanged = "yes" Then
        iCount = iCount + 1
      End If
      End If
   Next
   
   MsgBox "Number of contacts updated:" & Str$(iCount)

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

End Sub