Hurtowa zamiana domen w adresach email
by vbatools on Jun.22, 2010, under Outlook, Porady
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.
(c) Shon Oskar – www.VBATools.pl
Wszelkie prawa zastrzeżone. Żadna część ani całość tego artykułu nie może być powielana ani publikowana bez zgody autora.