M
Marc Koster
My company is changing its company name in the near future , so I
wrote this to be prepared.
The following code can be used to replace the company name in all your
contacts.
It replaces the company name of the contacts in your contact
folder. Place this code in a module of Outlook and run the
SubRunMeReplaceCompanyName
Option Explicit
Public intCount As Integer
Sub RunMeReplaceCompanyName()
' 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 company name of all the contacts
in your
' outlook folder and replaces it with a new specified company name
' In this routine all other routines are called from
Dim fldContactFolder As Outlook.MAPIFolder
Dim colFolders As Collection
Dim strOldCompanyName As String
Dim strNewCompanyName 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 names of your
contacts, " _
& Chr(10) & "in the MS Outlook contact folder" _
& Chr(10) & " by replacing 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
name." _
& 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 InputCompanyNameStrings is called
InputCompanyNameStrings strOldCompanyName, strNewCompanyName
' The routine ReplaceCompanyName that will replace the strings is
called.
ReplaceCompanyName fldContactFolder, colFolders,
strOldCompanyName, strNewCompanyName
' Messages to user while ending
MsgBox "Number of contacts updated:" & Str$(intCount), , "Contact
number updated"
MsgBox "The company name 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 ReplaceCompanyName(ByRef fldContactFolder As
Outlook.MAPIFolder, ByRef colFolders As Collection, ByRef
strOldCompanyName As String, ByRef strNewCompanyName 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 company name of all the contacts
in your
' outlook folder and replaces it with a new specified company name
' Specify which contact folder to work with to change the company
name
' In this routine the actual replacement is done.
Dim objContacts As Outlook.Items
Dim objContact As Object
' Set the counter to zero
intCount = 0
' Change old Company name 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
If TypeName(objContact) = "ContactItem" Then
If objContact.CompanyName = strOldCompanyName Then
objContact.CompanyName = strNewCompanyName
objContact.Save
intCount = intCount + 1
End If
End If
Next
Next
' Clean up
Set objContact = Nothing
Set objContacts = 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 company name of all the contacts
in your
' outlook folder and replaces it with a new specified company name
' 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 InputCompanyNameStrings(ByRef strOldCompanyName As String,
ByRef strNewCompanyName 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 company name of all the contacts
in your
' outlook folder and replaces it with a new specified company name
' in this routine the user inputs the old and new string
Dim varMsg As Variant
Dim varStyle As Variant
Dim varTitle As Variant
Dim varResponse As Variant
' Prompt for the old company name
strOldCompanyName = InputBox("Enter the old company name." &
Chr(10) & "Like this Cap Gemini Ernst & Young or CGEY")
' Checking whether the user wants to continue with empty old
company name string.
If strOldCompanyName = "" Then
varMsg = "Do you want to continue? " & Chr(10) & "The old company
name is empty, all empty company names will be replaced with the new
name."
varStyle = vbYesNo + vbCritical + vbDefaultButton2
varTitle = "Just Checking"
varResponse = MsgBox(varMsg, varStyle, varTitle)
If varResponse = vbNo Then
End
End If
End If
' Prompt for the new company name
strNewCompanyName = InputBox("Enter the new company name." &
Chr(10) & "Like this Cap Gemini or Cap")
' Checking whether the user wants to continue with empty new
company name string.
If strNewCompanyName = "" Then
varMsg = "Do you want to continue? " & Chr(10) & "The new company
name is empty, all old company names will be replaced with nothing."
varStyle = vbYesNo + vbCritical + vbDefaultButton2
varTitle = "Just Checking"
varResponse = MsgBox(varMsg, varStyle, varTitle)
If varResponse = vbNo Then
End
End If
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 Name: " & strOldCompanyName & Chr(10) & _
"New Company Name: " & strNewCompanyName
varStyle = vbYesNo + vbCritical + vbDefaultButton2
varTitle = "Just Checking"
varResponse = MsgBox(varMsg, varStyle, varTitle)
If varResponse = vbNo Then
End
End If
End Sub
wrote this to be prepared.
The following code can be used to replace the company name in all your
contacts.
It replaces the company name of the contacts in your contact
folder. Place this code in a module of Outlook and run the
SubRunMeReplaceCompanyName
Option Explicit
Public intCount As Integer
Sub RunMeReplaceCompanyName()
' 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 company name of all the contacts
in your
' outlook folder and replaces it with a new specified company name
' In this routine all other routines are called from
Dim fldContactFolder As Outlook.MAPIFolder
Dim colFolders As Collection
Dim strOldCompanyName As String
Dim strNewCompanyName 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 names of your
contacts, " _
& Chr(10) & "in the MS Outlook contact folder" _
& Chr(10) & " by replacing 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
name." _
& 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 InputCompanyNameStrings is called
InputCompanyNameStrings strOldCompanyName, strNewCompanyName
' The routine ReplaceCompanyName that will replace the strings is
called.
ReplaceCompanyName fldContactFolder, colFolders,
strOldCompanyName, strNewCompanyName
' Messages to user while ending
MsgBox "Number of contacts updated:" & Str$(intCount), , "Contact
number updated"
MsgBox "The company name 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 ReplaceCompanyName(ByRef fldContactFolder As
Outlook.MAPIFolder, ByRef colFolders As Collection, ByRef
strOldCompanyName As String, ByRef strNewCompanyName 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 company name of all the contacts
in your
' outlook folder and replaces it with a new specified company name
' Specify which contact folder to work with to change the company
name
' In this routine the actual replacement is done.
Dim objContacts As Outlook.Items
Dim objContact As Object
' Set the counter to zero
intCount = 0
' Change old Company name 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
If TypeName(objContact) = "ContactItem" Then
If objContact.CompanyName = strOldCompanyName Then
objContact.CompanyName = strNewCompanyName
objContact.Save
intCount = intCount + 1
End If
End If
Next
Next
' Clean up
Set objContact = Nothing
Set objContacts = 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 company name of all the contacts
in your
' outlook folder and replaces it with a new specified company name
' 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 InputCompanyNameStrings(ByRef strOldCompanyName As String,
ByRef strNewCompanyName 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 company name of all the contacts
in your
' outlook folder and replaces it with a new specified company name
' in this routine the user inputs the old and new string
Dim varMsg As Variant
Dim varStyle As Variant
Dim varTitle As Variant
Dim varResponse As Variant
' Prompt for the old company name
strOldCompanyName = InputBox("Enter the old company name." &
Chr(10) & "Like this Cap Gemini Ernst & Young or CGEY")
' Checking whether the user wants to continue with empty old
company name string.
If strOldCompanyName = "" Then
varMsg = "Do you want to continue? " & Chr(10) & "The old company
name is empty, all empty company names will be replaced with the new
name."
varStyle = vbYesNo + vbCritical + vbDefaultButton2
varTitle = "Just Checking"
varResponse = MsgBox(varMsg, varStyle, varTitle)
If varResponse = vbNo Then
End
End If
End If
' Prompt for the new company name
strNewCompanyName = InputBox("Enter the new company name." &
Chr(10) & "Like this Cap Gemini or Cap")
' Checking whether the user wants to continue with empty new
company name string.
If strNewCompanyName = "" Then
varMsg = "Do you want to continue? " & Chr(10) & "The new company
name is empty, all old company names will be replaced with nothing."
varStyle = vbYesNo + vbCritical + vbDefaultButton2
varTitle = "Just Checking"
varResponse = MsgBox(varMsg, varStyle, varTitle)
If varResponse = vbNo Then
End
End If
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 Name: " & strOldCompanyName & Chr(10) & _
"New Company Name: " & strNewCompanyName
varStyle = vbYesNo + vbCritical + vbDefaultButton2
varTitle = "Just Checking"
varResponse = MsgBox(varMsg, varStyle, varTitle)
If varResponse = vbNo Then
End
End If
End Sub