VBA Tools

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.

Option Explicit
Sub zamiana_domen()
'MVP OShon from VBATools.pl
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. Przykładowe 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 na Outlook.pl.

Wszelkie prawa zastrzeżone. Żadna część ani całość tego artykułu nie może być powielana ani publikowana bez zgody autora.