Sub NormalizeNumbers_Click()
Dim objRegEx, objRegExpStrip
Dim arrMatchPattern(3), arrUpdatePattern(3)
Const olFolderContacts = 10
'Pattern to match North American numbers
arrMatchPattern(0) = "^\+?1?\D*(\d\d\d)\D*(\d\d\d)\D*(\d\d\d\d)\s*$"
arrUpdatePattern(0) = "+1 ($1) $2-$3"
'Pattern to match North American numbers with extensions
arrMatchPattern(1) = "^\+?1?\D*(\d\d\d)\D*(\d\d\d)\D*(\d\d\d\d)\D+(\d+)\s*$"
arrUpdatePattern(1) = "+1 ($1) $2-$3 x $4"
'Pattern to match international numbers with extension
arrMatchPattern(2) = "^\+?(011)?\D*([2-9]\d{0,2})\D*([\d\.\-\s\)]{7,})[A-Za-z]+[\;\:\=\s]+(\d+)\s*$"
arrUpdatePattern(2) = "+$2 $3 x $4"
'Pattern to match international numbers
arrMatchPattern(3) = "^\+?(011)?\D*([2-9]\d{0,2})\D*([\d\.\s\-\)]{7,})\s*$"
arrUpdatePattern(3) = "+$2 $3"
Set olMAPI = Application.GetNameSpace("MAPI")
Set folder = olMAPI.GetDefaultFolder(olFolderContacts)
Set items = folder.items
Count = items.Count
If Count = 0 Then
MsgBox "Nothing to do!"
Exit Sub
End If
'Filter on the message class to obtain only contact items in the folder
Set contactItems = items.Restrict("[MessageClass]='IPM.Contact'")
For Each itemContact In Items
bUpdated = vbFALSE
bMatchAssist = vbFALSE
bMatchBus2 = vbFALSE
bMatchBusFax = vbFALSE
bMatchBus = vbFALSE
bMatchCallback = vbFALSE
bMatchCar = vbFALSE
bMatchCompMain = vbFALSE
bMatchHome2 = vbFALSE
bMatchHomeFax = vbFALSE
bMatchHome = vbFALSE
bMatchMobile = vbFALSE
bMatchOtherFax = vbFALSE
bMatchOther = vbFALSE
bMatchPager = vbFALSE
bMatchPrimary = vbFALSE
bMatchRadio = vbFALSE
bMatchTTY = vbFALSE
bUpdated = vbFALSE
strAssistantTelephoneNumber = ""
strBusiness2TelephoneNumber = ""
strBusinessFaxNumber = ""
strBusinessTelephoneNumber = ""
strCallbackTelephoneNumber = ""
strCarTelephoneNumber = ""
strCompanyMainTelephoneNumber = ""
strHome2TelephoneNumber = ""
strHomeFaxNumber = ""
strHomeTelephoneNumber = ""
strMobileTelephoneNumber = ""
strOtherFaxNumber = ""
strOtherTelephoneNumber = ""
strPagerNumber = ""
strPrimaryTelephoneNumber = ""
strRadioTelephoneNumber = ""
strTTYTDDTelephoneNumber = ""
On Error Resume Next
strAssistantTelephoneNumber = itemContact.AssistantTelephoneNumber
strBusiness2TelephoneNumber = itemContact.Business2TelephoneNumber
strBusinessFaxNumber = itemContact.BusinessFaxNumber
strBusinessTelephoneNumber = itemContact.BusinessTelephoneNumber
strCallbackTelephoneNumber = itemContact.CallbackTelephoneNumber
strCarTelephoneNumber = itemContact.CarTelephoneNumber
strCompanyMainTelephoneNumber = itemContact.CompanyMainTelephoneNumber
strHome2TelephoneNumber = itemContact.Home2TelephoneNumber
strHomeFaxNumber = itemContact.HomeFaxNumber
strHomeTelephoneNumber = itemContact.HomeTelephoneNumber
strMobileTelephoneNumber = itemContact.MobileTelephoneNumber
strOtherFaxNumber = itemContact.OtherFaxNumber
strOtherTelephoneNumber = itemContact.OtherTelephoneNumber
strPagerNumber = itemContact.PagerNumber
strPrimaryTelephoneNumber = itemContact.PrimaryTelephoneNumber
strRadioTelephoneNumber = itemContact.RadioTelephoneNumber
strTTYTDDTelephoneNumber = itemContact.TTYTDDTelephoneNumber
On Error GoTo 0
For x = 0 to UBound(arrMatchPattern)
If strAssistantTelephoneNumber <> "" AND bMatchAssist = vbFALSE Then Call NormalizePhone(strAssistantTelephoneNumber, arrMatchPattern(x), arrUpdatePattern(x), bMatchAssist, bUpdated)
If strBusiness2TelephoneNumber <> "" AND bMatchBus2 = vbFALSE Then Call NormalizePhone(strBusiness2TelephoneNumber, arrMatchPattern(x), arrUpdatePattern(x), bMatchBus2, bUpdated)
If strBusinessFaxNumber <> "" AND bMatchBusFax = vbFALSE Then Call NormalizePhone(strBusinessFaxNumber, arrMatchPattern(x), arrUpdatePattern(x), bMatchBusFax, bUpdated)
If strBusinessTelephoneNumber <> "" AND bMatchBus = vbFALSE Then Call NormalizePhone(strBusinessTelephoneNumber, arrMatchPattern(x), arrUpdatePattern(x), bMatchBus, bUpdated)
If strCallbackTelephoneNumber <> "" AND bMatchCallback = vbFALSE Then Call NormalizePhone(strCallbackTelephoneNumber, arrMatchPattern(x), arrUpdatePattern(x), bMatchCallback, bUpdated)
If strCarTelephoneNumber <> "" AND bMatchCar = vbFALSE Then Call NormalizePhone(strCarTelephoneNumber, arrMatchPattern(x), arrUpdatePattern(x), bMatchCar, bUpdated)
If strCompanyMainTelephoneNumber <> "" AND bMatchCompMain = vbFALSE Then Call NormalizePhone(strCompanyMainTelephoneNumber, arrMatchPattern(x), arrUpdatePattern(x), bMatchCompMain, bUpdated)
If strHome2TelephoneNumber <> "" AND bMatchHome2 = vbFALSE Then Call NormalizePhone(strHome2TelephoneNumber, arrMatchPattern(x), arrUpdatePattern(x), bMatchHome2, bUpdated)
If strHomeFaxNumber <> "" AND bMatchHomeFax = vbFALSE Then Call NormalizePhone(strHomeFaxNumber, arrMatchPattern(x), arrUpdatePattern(x), bMatchHomeFax, bUpdated)
If strHomeTelephoneNumber <> "" AND bMatchHome = vbFALSE Then Call NormalizePhone(strHomeTelephoneNumber, arrMatchPattern(x), arrUpdatePattern(x), bMatchHome, bUpdated)
If strMobileTelephoneNumber <> "" AND bMatchMobile = vbFALSE Then Call NormalizePhone(strMobileTelephoneNumber, arrMatchPattern(x), arrUpdatePattern(x), bMatchMobile, bUpdated)
If strOtherFaxNumber <> "" AND bMatchOtherFax = vbFALSE Then Call NormalizePhone(strOtherFaxNumber, arrMatchPattern(x), arrUpdatePattern(x), bMatchOtherFax, bUpdated)
If strOtherTelephoneNumber <> "" AND bMatchOther = vbFALSE Then Call NormalizePhone(strOtherTelephoneNumber, arrMatchPattern(x), arrUpdatePattern(x), bMatchOther, bUpdated)
If strPagerNumber <> "" AND bMatchPager = vbFALSE Then Call NormalizePhone(strPagerNumber, arrMatchPattern(x), arrUpdatePattern(x), bMatchPager, bUpdated)
If strPrimaryTelephoneNumber <> "" AND bMatchPrimary = vbFALSE Then Call NormalizePhone(strPrimaryTelephoneNumber, arrMatchPattern(x), arrUpdatePattern(x), bMatchPrimary, bUpdated)
If strRadioTelephoneNumber <> "" AND bMatchRadio = vbFALSE Then Call NormalizePhone(strRadioTelephoneNumber, arrMatchPattern(x), arrUpdatePattern(x), bMatchRadio, bUpdated)
If strTTYTDDTelephoneNumber <> "" AND bMatchTTY = vbFALSE Then Call NormalizePhone(strTTYTDDTelephoneNumber, arrMatchPattern(x), arrUpdatePattern(x), bMatchTTY, bUpdated)
Next
If bUpdated = vbTRUE Then
If bMatchAssist = vbTRUE Then itemContact.AssistantTelephoneNumber = strAssistantTelephoneNumber
If bMatchBus2 = vbTRUE Then itemContact.Business2TelephoneNumber = strBusiness2TelephoneNumber
If bMatchBusFax = vbTRUE Then itemContact.BusinessFaxNumber = strBusinessFaxNumber
If bMatchBus = vbTRUE Then itemContact.BusinessTelephoneNumber = strBusinessTelephoneNumber
If bMatchCallback = vbTRUE Then itemContact.CallbackTelephoneNumber = strCallbackTelephoneNumber
If bMatchCar = vbTRUE Then itemContact.CarTelephoneNumber = strCarTelephoneNumber
If bMatchCompMain = vbTRUE Then itemContact.CompanyMainTelephoneNumber = strCompanyMainTelephoneNumber
If bMatchHome2 = vbTRUE Then itemContact.Home2TelephoneNumber = strHome2TelephoneNumber
If bMatchHomeFax = vbTRUE Then itemContact.HomeFaxNumber = strHomeFaxNumber
If bMatchHome = vbTRUE Then itemContact.HomeTelephoneNumber = strHomeTelephoneNumber
If bMatchMobile = vbTRUE Then itemContact.MobileTelephoneNumber = strMobileTelephoneNumber
If bMatchOtherFax = vbTRUE Then itemContact.OtherFaxNumber = strOtherFaxNumber
If bMatchOther = vbTRUE Then itemContact.OtherTelephoneNumber = strOtherTelephoneNumber
If bMatchPager = vbTRUE Then itemContact.PagerNumber = strPagerNumber
If bMatchPrimary = vbTRUE Then itemContact.PrimaryTelephoneNumber = strPrimaryTelephoneNumber
If bMatchRadio = vbTRUE Then itemContact.RadioTelephoneNumber = strRadioTelephoneNumber
If bMatchTTY = vbTRUE Then itemContact.TTYTDDTelephoneNumber = strTTYTDDTelephoneNumber
itemContact.Save
End If
Next
MsgBox "Your contacts have been updated."
End Sub
'****************************************************************************************************************************************************
'PROCEDURE NormalizePhone(strPhone, strNewPhone, strType, bMatch)
'===============================================================
'Normalizes phone numbers to match regular expression pattern
'
'Input: strPhone - array of phone numbers to update in AD
' strNewPhone - temporary holding spot for updated phones
' strType - Phone type. Used only for display purposes
' bMatch - Set to vbTRUE if a pattern match is found. Prevents further match hunting.
'
'Output: Phone numbers updated as per regular expression
'****************************************************************************************************************************************************
Sub NormalizePhone(strPhone, strMatchPattern, strUpdatePattern, bMatch, bUpdated)
Dim objMatch, strNewPhone
'Set Regular Expression for phone pattern matching
Set objRegEx = CreateObject("VBScript.RegExp")
objRegEx.IgnoreCase = True
objRegEx.Global = True
'Set Regular Expression for removing extraneous characters
Set objRegExStrip = CreateObject("VBScript.RegExp")
objRegExStrip.IgnoreCase = True
objRegExStrip.Global = True
objRegEx.Pattern = strMatchPattern
Set objMatch = objRegEx.Execute(strPhone)
If objMatch.Count > 0 Then
strNewPhone = objRegEx.Replace(strPhone, strUpdatePattern)
'Replace dashes, brackets or spaces with periods and trim trailing spaces, only for international numbers
If InStr(strUpdatePattern, "($1)") = 0 Then
objRegExStrip.Pattern = "[\.\-\)]"
strNewPhone = objRegExStrip.Replace(RTrim(strNewPhone), " ")
End If
If strNewPhone <> strPhone Then
bMatch = vbTRUE
bUpdated = vbTRUE
strPhone = strNewPhone
End If
End If
End Sub
