Hurtowa zamiana domen w adresach email

W niektórych przypadkach zachodzi konieczność zmiany domeny w istniejących kontaktach Outlooka. Podyktowane jest to np. migracją pracowników pod skrzydła innej firmy, bądź rejestracją nowej domeny. Wyszukiwanie i edytowanie wszystkich adresów ręcznie (np. z odbiorca@abc.com.pl na odbiorca@nowa_nazwa.pl) spędza sen z powiek. Brak takiej modyfikacji może po wygaśnięciu warunków przekierowania wiadomości ze starej domeny spowodować, iż nasza poczta nie trafi do adresata.

Poniższa procedura uruchamia dwa okna, w których należy wpisać część adresu po znaku @ (domenę do zmiany) oraz domenę, na jaką adresy mają być zamienione. 

Sub zamiana_domen()
Dim oContact As ContactItem
Dim oContactFolder As MAPIFolder
Dim x&, item As Object, msg$, Stara_domena$, Nowa_domena$, Message$

Message = "Podaj nazwę domeny do zamiany." & vbCr & vbCr _
        & "Domena to wartośc znajdujaca się po znaku @ adresie Email."
Stara_domena = InputBox(Message, "Zamiana domen w adresach email. Krok 1/2")
Message = "Podaj nazwę nowej domeny, na którą będzie zmianiona: " & Stara_domena & vbCr & vbCr _
        & "Domena to wartośc znajdujaca się po znaku @ adresie Email."
Nowa_domena = InputBox(Message, "Zamiana domen w adresach email. Krok  2/2")

If Len(Stara_domena) = 0 Or Len(Nowa_domena) = 0 Then GoTo koniec
On Error GoTo blad

'procedura uwzględnia domyślny katalog folderów
Set oContactFolder = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts)
For x = 1 To oContactFolder.Items.Count
    If oContactFolder.Items(x).Class <> 40 Then GoTo nastepny
    Set oContact = oContactFolder.Items(x)
        DoEvents
            If Not oContact Is Nothing Then
                With oContact
                    If .Email1Address Like "*" & Trim(Stara_domena) & "*" Or _
                       .Email1Address Like "*" & Trim(Stara_domena) Then
                       .Email1Address = Split(.Email1Address, "@")(0) & "@" & Trim(Nowa_domena)
                        msg = msg & .FullName & " -> adres zamieniamy z: " & .Email1Address & " -> na: " & _
                                    Split(.Email1Address, "@")(0) & "@" & Trim(Nowa_domena) & vbCr
                        .Save
                    End If
                End With
            End If
nastepny:
Next
    If Len(msg) = 0 Then
        MsgBox "Brak adresów spełniających warunek" & vbCr _
            & Stara_domena & " -> " & Nowa_domena, vbInformation, "Procedura ''Zamiana domen''"
    Else
        MsgBox msg, vbInformation, "Procedura ''Zamiana domen''"
    End If
Set oContact = Nothing
Set oContactFolder = Nothing
Exit Sub
koniec:
  MsgBox "Nie podano wymaganych parametrów procedury" & vbCr _
       & "Proces zamiany domen został anulowany", vbExclamation, " Informacja o błędzie"
Exit Sub

blad:
  MsgBox "Błąd procedury: ''zamiana_domen''" & vbCr _
       & Err.Number & vbCr _
       & Err.Description, vbExclamation, " Informacja o błędzie"
End Sub

Aby osadzić procedurę „zamiana_domen” pod przyciskiem w menu MS Outlook, polecam uwadze ten artykuł.

Postępowanie krokowe w makro:

• sprawdza, czy podano starą i nowa domenę
• przeszukuje domyślny folder kontaktów w poszukiwaniu starej domeny
• zamienia domeny i zapisuje kontakt, bez modyfikacji innych danych w kontakcie
• po zakończeniu procedury informuje o przebiegu procesu

Makro nie zamienia adresów w listach dystrybucyjnych (dot. tylko kontaktów).

Aplikację można rozszerzyć budując interfejs w developerze języka VBA, dodając np. tekstowe okienka i przypisując do nich zmienne odpowiadające pierwotnie komendzie InputBox zawartej w powyższej procedurze, usuwając linie wywołania komunikatów.

Rys. 1. Okno wyświetlone po uruchomieniu procedury.

Posiadając listę adresów w pliku tekstowym, możemy też przeprowadzić zamianę każdego adresu z osobna. Więcej o tym w tym wątku.