M
Marc Koster
My company is changing its email address in the near future , so I
wrote this to be prepared.
The following code can be used to replace email strings in all your
contacts.
It replaces parts of the company email adresses of the contacts in
your contact
folder. Place this code in a module of Outlook and run the Sub
RunMeReplaceCompanyEmailAddress
---------------------
Option Explicit
Public intCount As Integer
Sub RunMeReplaceCompanyEmailAddress()
' Author Marc Koster van Groos, using several internet code
examples from slipstick.com
' use this code at you own risk and do not forget to backup your
MS Outlook .pst file
' This VBA code finds a specified string in the email addresses of
all the contacts in your
' outlook folder and replaces it with a new specified string
' In this routine all other routines are called from
Dim fldContactFolder As Outlook.MAPIFolder
Dim colFolders As Collection
Dim strOldEmailAddress As String
Dim strNewEmailAddress As String
Dim varNumber As Variant
Set colFolders = New Collection
' Tell the user what is going to happen
MsgBox "This routine will replace all the company email
addresses," _
& Chr(10) & "of your contacts in the MS Outlook contact folder
with new addresses ." _
& Chr(10) & "It will only replace the last part of the email
address," _
& Chr(10) & "like everything after and including the @ character"
_
& Chr(10) & " It will replace a specified (by you) string with
another specified (by you) string." _
& Chr(10) & "You have several chances to opt out." _
& Chr(10) & "This routine has three phases:" _
& Chr(10) & "phase 1 where you pick the contact folder." _
& Chr(10) & "phase 2 where you specify the old and new company
email address." _
& Chr(10) & "phase 3 where the strings are replaced and ending.",
, "What is going to happen?"
' Let user pick the appropiated contact folder
Set fldContactFolder = Application.Session.PickFolder()
' check if user has choosen a contact folder
If Not fldContactFolder Is Nothing Then
' The routine FindAllContactFolders finds all the folder and
subfolders.
FindAllContactFolders fldContactFolder, colFolders
'varNumber = colFolders.Count
' user is asked to input the necessary strings.
' the routine InputEmailStrings is called
InputEmailStrings strOldEmailAddress, strNewEmailAddress
' The routine ReplaceCompanyEmailAddress that will replace the
strings is called.
ReplaceCompanyEmailAddress fldContactFolder, colFolders,
strOldEmailAddress, strNewEmailAddress
' Messages to user while ending
MsgBox "Number of contacts updated:" & Str$(intCount), , "Contact
number updated"
MsgBox "The company email address replacement has been done." &
Chr(10) & "It was a pleasure working with you.", , "Goodbye"
Else
MsgBox "You have not picked a contact folder", , "Contact folder
is empty"
Exit Sub
End If
' Clean up
Set fldContactFolder = Nothing
Set colFolders = Nothing
End Sub
Public Sub FindAllContactFolders(ByRef fldContactFolder As
Outlook.MAPIFolder, ByRef colFolders As Collection)
' Author Marc Koster van Groos, using several internet code
examples from slipstick.com
' use this code at you own risk and do not forget to backup your
MS Outlook .pst file
' This VBA code finds a specified string in the email addresses of
all the contacts in your
' outlook folder and replaces it with a new specified string
' In this routine the contacts folders are sought and memorized
Dim fldSubContactFolder As Outlook.MAPIFolder
'Add Contact Mainfolder to collection colFolders
If fldContactFolder.DefaultItemType = olContactItem Then
'MsgBox "The name of the added Main Contact folder is: " &
Chr(10) & Chr(10) & fldContactFolder.Name
colFolders.Add fldContactFolder
End If
'Add Contact subfolders to collection colFolders
For Each fldSubContactFolder In fldContactFolder.Folders
If fldSubContactFolder.DefaultItemType = olContactItem
Then
'MsgBox "The name of the added sub Contact folder is: " &
Chr(10) & Chr(10) & fldSubContactFolder.Name
colFolders.Add fldSubContactFolder
End If
Next
End Sub
Public Sub InputEmailStrings(ByRef strOldEmailAddress As String, ByRef
strNewEmailAddress As String)
' Author Marc Koster van Groos, using several internet code
examples from slipstick.com
' use this code at you own risk and do not forget to backup your
MS Outlook .pst file
' This VBA code finds a specified string in the email addresses of
all the contacts in your
' outlook folder and replaces it with a new specified string
' in this routine the user inputs the old and new email string
Dim varMsg As Variant
Dim varStyle As Variant
Dim varTitle As Variant
Dim varResponse As Variant
' Prompt for the old company email address
strOldEmailAddress = InputBox("Enter the old company email
address." & Chr(10) & "Like this @capgemini.nl or @cgey.nl")
' Aborting when the user wants to continue with an empty old
company email address string.
If strOldEmailAddress = "" Then
MsgBox "The old company email address input is empty; try again",
, "Old company email address input empty"
End
End If
' Prompt for the new company email address
strNewEmailAddress = InputBox("Enter the new company email
address." & Chr(10) & "Like this @cg.nl or @cap.nl")
' Aborting when the user wants to continue with an empty new
company email address string.
If strNewEmailAddress = "" Then
MsgBox "The new company email address input is empty; try again",
, "New company email address input empty"
End
End If
' Checking whether the user wants to continue and realizes the risk.
varMsg = "Do you want to continue? " & Chr(10) & _
"Have you made a backup of your MS Outlook .pst file?" & Chr(10) &
_
"Old Company Email Address String: " & strOldEmailAddress &
Chr(10) & _
"New Company Email Address String: " & strNewEmailAddress
varStyle = vbYesNo + vbCritical + vbDefaultButton2
varTitle = "Just Checking"
varResponse = MsgBox(varMsg, varStyle, varTitle)
If varResponse = vbNo Then
End
End If
End Sub
Public Sub ReplaceCompanyEmailAddress(ByRef fldContactFolder As
Outlook.MAPIFolder, ByRef colFolders As Collection, ByRef
strOldEmailAddress As String, ByRef strNewEmailAddress As String)
' Author Marc Koster van Groos, using several internet code
examples from slipstick.com
' use this code at you own risk and do not forget to backup your
MS Outlook .pst file
' This VBA code finds a specified string in the email addresses of
all the contacts in your
' outlook folder and replaces it with a new specified string
' In this routine the actual replacement is done.
Dim objContacts As Outlook.Items
Dim objContact As Object
Dim blnFound As Boolean
' Set the counter to zero
intCount = 0
' Change old Company email address to new one
' Process the changes per folder
For Each fldContactFolder In colFolders
' Set all the contacts from the specified contact folder
Set objContacts = fldContactFolder.Items
' Loop through all the contacts in contact folder and replace
when neccesary
For Each objContact In objContacts
' keep track when email address has been changed so boolean is
set at false
blnFound = False
' must test for item type to avoid distribution lists
If TypeName(objContact) = "ContactItem" Then
If InStr(objContact.Email1Address, strOldEmailAddress) > 0
Then
objContact.Email1Address = Replace(objContact.Email1Address,
strOldEmailAddress, strNewEmailAddress)
blnFound = True
End If
If InStr(objContact.Email2Address, strOldEmailAddress) > 0
Then
objContact.Email2Address = Replace(objContact.Email2Address,
strOldEmailAddress, strNewEmailAddress)
blnFound = True
End If
If InStr(objContact.Email3Address, strOldEmailAddress) > 0
Then
objContact.Email3Address = Replace(objContact.Email3Address,
strOldEmailAddress, strNewEmailAddress)
blnFound = True
End If
If blnFound = True Then
' The email address has been changed so contact is saved
objContact.Save
intCount = intCount + 1
End If
End If
Next
Next
' Clean up
Set objContact = Nothing
Set objContacts = Nothing
End Sub
wrote this to be prepared.
The following code can be used to replace email strings in all your
contacts.
It replaces parts of the company email adresses of the contacts in
your contact
folder. Place this code in a module of Outlook and run the Sub
RunMeReplaceCompanyEmailAddress
---------------------
Option Explicit
Public intCount As Integer
Sub RunMeReplaceCompanyEmailAddress()
' Author Marc Koster van Groos, using several internet code
examples from slipstick.com
' use this code at you own risk and do not forget to backup your
MS Outlook .pst file
' This VBA code finds a specified string in the email addresses of
all the contacts in your
' outlook folder and replaces it with a new specified string
' In this routine all other routines are called from
Dim fldContactFolder As Outlook.MAPIFolder
Dim colFolders As Collection
Dim strOldEmailAddress As String
Dim strNewEmailAddress As String
Dim varNumber As Variant
Set colFolders = New Collection
' Tell the user what is going to happen
MsgBox "This routine will replace all the company email
addresses," _
& Chr(10) & "of your contacts in the MS Outlook contact folder
with new addresses ." _
& Chr(10) & "It will only replace the last part of the email
address," _
& Chr(10) & "like everything after and including the @ character"
_
& Chr(10) & " It will replace a specified (by you) string with
another specified (by you) string." _
& Chr(10) & "You have several chances to opt out." _
& Chr(10) & "This routine has three phases:" _
& Chr(10) & "phase 1 where you pick the contact folder." _
& Chr(10) & "phase 2 where you specify the old and new company
email address." _
& Chr(10) & "phase 3 where the strings are replaced and ending.",
, "What is going to happen?"
' Let user pick the appropiated contact folder
Set fldContactFolder = Application.Session.PickFolder()
' check if user has choosen a contact folder
If Not fldContactFolder Is Nothing Then
' The routine FindAllContactFolders finds all the folder and
subfolders.
FindAllContactFolders fldContactFolder, colFolders
'varNumber = colFolders.Count
' user is asked to input the necessary strings.
' the routine InputEmailStrings is called
InputEmailStrings strOldEmailAddress, strNewEmailAddress
' The routine ReplaceCompanyEmailAddress that will replace the
strings is called.
ReplaceCompanyEmailAddress fldContactFolder, colFolders,
strOldEmailAddress, strNewEmailAddress
' Messages to user while ending
MsgBox "Number of contacts updated:" & Str$(intCount), , "Contact
number updated"
MsgBox "The company email address replacement has been done." &
Chr(10) & "It was a pleasure working with you.", , "Goodbye"
Else
MsgBox "You have not picked a contact folder", , "Contact folder
is empty"
Exit Sub
End If
' Clean up
Set fldContactFolder = Nothing
Set colFolders = Nothing
End Sub
Public Sub FindAllContactFolders(ByRef fldContactFolder As
Outlook.MAPIFolder, ByRef colFolders As Collection)
' Author Marc Koster van Groos, using several internet code
examples from slipstick.com
' use this code at you own risk and do not forget to backup your
MS Outlook .pst file
' This VBA code finds a specified string in the email addresses of
all the contacts in your
' outlook folder and replaces it with a new specified string
' In this routine the contacts folders are sought and memorized
Dim fldSubContactFolder As Outlook.MAPIFolder
'Add Contact Mainfolder to collection colFolders
If fldContactFolder.DefaultItemType = olContactItem Then
'MsgBox "The name of the added Main Contact folder is: " &
Chr(10) & Chr(10) & fldContactFolder.Name
colFolders.Add fldContactFolder
End If
'Add Contact subfolders to collection colFolders
For Each fldSubContactFolder In fldContactFolder.Folders
If fldSubContactFolder.DefaultItemType = olContactItem
Then
'MsgBox "The name of the added sub Contact folder is: " &
Chr(10) & Chr(10) & fldSubContactFolder.Name
colFolders.Add fldSubContactFolder
End If
Next
End Sub
Public Sub InputEmailStrings(ByRef strOldEmailAddress As String, ByRef
strNewEmailAddress As String)
' Author Marc Koster van Groos, using several internet code
examples from slipstick.com
' use this code at you own risk and do not forget to backup your
MS Outlook .pst file
' This VBA code finds a specified string in the email addresses of
all the contacts in your
' outlook folder and replaces it with a new specified string
' in this routine the user inputs the old and new email string
Dim varMsg As Variant
Dim varStyle As Variant
Dim varTitle As Variant
Dim varResponse As Variant
' Prompt for the old company email address
strOldEmailAddress = InputBox("Enter the old company email
address." & Chr(10) & "Like this @capgemini.nl or @cgey.nl")
' Aborting when the user wants to continue with an empty old
company email address string.
If strOldEmailAddress = "" Then
MsgBox "The old company email address input is empty; try again",
, "Old company email address input empty"
End
End If
' Prompt for the new company email address
strNewEmailAddress = InputBox("Enter the new company email
address." & Chr(10) & "Like this @cg.nl or @cap.nl")
' Aborting when the user wants to continue with an empty new
company email address string.
If strNewEmailAddress = "" Then
MsgBox "The new company email address input is empty; try again",
, "New company email address input empty"
End
End If
' Checking whether the user wants to continue and realizes the risk.
varMsg = "Do you want to continue? " & Chr(10) & _
"Have you made a backup of your MS Outlook .pst file?" & Chr(10) &
_
"Old Company Email Address String: " & strOldEmailAddress &
Chr(10) & _
"New Company Email Address String: " & strNewEmailAddress
varStyle = vbYesNo + vbCritical + vbDefaultButton2
varTitle = "Just Checking"
varResponse = MsgBox(varMsg, varStyle, varTitle)
If varResponse = vbNo Then
End
End If
End Sub
Public Sub ReplaceCompanyEmailAddress(ByRef fldContactFolder As
Outlook.MAPIFolder, ByRef colFolders As Collection, ByRef
strOldEmailAddress As String, ByRef strNewEmailAddress As String)
' Author Marc Koster van Groos, using several internet code
examples from slipstick.com
' use this code at you own risk and do not forget to backup your
MS Outlook .pst file
' This VBA code finds a specified string in the email addresses of
all the contacts in your
' outlook folder and replaces it with a new specified string
' In this routine the actual replacement is done.
Dim objContacts As Outlook.Items
Dim objContact As Object
Dim blnFound As Boolean
' Set the counter to zero
intCount = 0
' Change old Company email address to new one
' Process the changes per folder
For Each fldContactFolder In colFolders
' Set all the contacts from the specified contact folder
Set objContacts = fldContactFolder.Items
' Loop through all the contacts in contact folder and replace
when neccesary
For Each objContact In objContacts
' keep track when email address has been changed so boolean is
set at false
blnFound = False
' must test for item type to avoid distribution lists
If TypeName(objContact) = "ContactItem" Then
If InStr(objContact.Email1Address, strOldEmailAddress) > 0
Then
objContact.Email1Address = Replace(objContact.Email1Address,
strOldEmailAddress, strNewEmailAddress)
blnFound = True
End If
If InStr(objContact.Email2Address, strOldEmailAddress) > 0
Then
objContact.Email2Address = Replace(objContact.Email2Address,
strOldEmailAddress, strNewEmailAddress)
blnFound = True
End If
If InStr(objContact.Email3Address, strOldEmailAddress) > 0
Then
objContact.Email3Address = Replace(objContact.Email3Address,
strOldEmailAddress, strNewEmailAddress)
blnFound = True
End If
If blnFound = True Then
' The email address has been changed so contact is saved
objContact.Save
intCount = intCount + 1
End If
End If
Next
Next
' Clean up
Set objContact = Nothing
Set objContacts = Nothing
End Sub