Batch change of domain names in e-mail addresses

Sometimes you need to change domain names in contacts in Outlook because the employees move to a different company or company migrates to a different e-mail provider. Searching and editing all addresses manually (e.g. from receipient@abc.com to receipient@new_name.com) may be tiresome. If we fail to modify the addresses our mail will stop delivering once forwarding service from the old to new domain expires.

The procedure that follows opens two windows: the first one is where you put a domain name after the "@" symbol (the domain you want to change), and the second window is where you put the new domain name (Fig. 1).

Fig. 1. Two windows displayed during the procedure.

Sub domain_change()     
Dim oContact As ContactItem     
Dim oContactFolder As MAPIFolder     
Dim x&, item As Object, msg$, Old_domain$, New_domain$, Message$
    Message = "Provide the domain name to change." & vbCr & vbCr _
    & "A domain is a name after the @ symbol in the e-mail address."
    Old_domain = InputBox(Message, "Changing domain names in e-mail addresses. Step 1/2")
    Message = "Provide a new domain name that will be replaced with: " & Old_domain & vbCr & vbCr _
    & "A domain is a name after the @ symbol in the e-mail address."
    New_domain = InputBox(Message, "Changing domain names in e-mail addresses. Step 2/2")
    If Len(Old_domain) = 0 Or Len(New_domain) = 0 Then GoTo finish
    On Error GoTo errors
    'the procedure applies to the default list of folders
    oContactFolder = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts)
    For x = 1 To oContactFolder.Items.Count
        If oContactFolder.Items(x).Class <> 40 Then GoTo nextstep
        oContact = oContactFolder.Items(x)
        DoEvents()
        If Not oContact Is Nothing Then
            With oContact
                If .Email1Address Like "*" & Trim(Old_domain) & "*" Or _
                .Email1Address Like "*" & Trim(Old_domain) Then
                    .Email1Address = Split(.Email1Address, "@")(0) & "@" & Trim(New_domain)
                    msg = msg & .FullName & " -> address changed from: " & .Email1Address & " -> to: " & _
                    Split(.Email1Address, "@")(0) & "@" & Trim(New_domain) & vbCr
                    .Save()
                End If
            End With
        End If
nextstep:
    Next
    If Len(msg) = 0 Then
        MsgBox("No address meets the condition" & vbCr _
        & Old_domain & " -> " & New_domain, vbInformation, "Procedure ''Domain change''")
    Else
        MsgBox(msg, vbInformation, "Procedure ''Domain change''")
    End If
    oContact = Nothing
    oContactFolder = Nothing
    Exit Sub
finish:
    MsgBox("No values were provided for the procedure" & vbCr _
    & "Changing domain namaes has been canceled", vbExclamation, " Error warning")
    Exit Sub
errors:
    MsgBox("Procedure's error: ''domain_change''" & vbCr _
    & Err.Number & vbCr _
    & Err.Description, vbExclamation, " Error warning")
End Sub

To learn how to mount the "domain_change" procedure onto a button on the MS Outlook menu, read this article.

This macro is responsible for:

• checking if both the old and new domain are provided

• searching the default contact folder for the old domain

• changing the domain and saving the contact item, without any other modifications in the contact item

• displaying the results on finishing.

This macro does not change the names in distribution lists (only contacts items).

You can develop this application by building an interface in VBA. For example, you can add text boxes and assign variables to them from the InputBox command in the above procedure, and delete the lines with warnings.

© All rights reserved. No part or whole of this article may not be reproduced or published without prior permission.
Oryginal article publicate at this page