W kliencie poczty Microsoft Outlook nie ma możliwości prostego, hurtowego zapisu kontaktów do książki adresowej, a co więcej nie można również jednym kliknięciem zapisać adresatów listy dystrybucyjnej (grupy zebranych adresatów przypisanych jako jedną zdefiniowaną grupę odbiorców wiadomości).
Outlook otrzymując adres email może nie otrzymać „nazwy wyświetlanej” adresu, lub może ona być myląca - to też mechanizm jaki miałby dodawać adresy do książki adresowej tworzył by pełen śmietnik danych na pierwszy rzut oka nie do ogarnięcia.
Nazwa wyświetlana to pole nie obowiązkowe jakie wpisuje nadawca podczas konfiguracji konta, a przekazywana potem wraz z adresem. Jeśli sam użytkownik, odbiorca wiadomości w takim przypadku nie uzupełni właściwie nazwy (Imię Nazwisko lub Nazwa instytucji) dla otrzymanego adresu to w książce adresowej otrzyma wiele niemówiących nic adresów email.
Inaczej jest w przypadku przekazywania wiadomości grupie osób, gdzie ich personalizacja nie musi być uzupełniona (wpisanie na listę promocyjną, wysyłany humor czy korespondencja okolicznościowa). Lista bowiem może składać się z wpisanych adresów oraz z wybranych adresatów.
W tym przypadku poniższe makro po zaznaczeniu otrzymanych wiadomości (z Ctrl) i podaniu w wyświetlonym oknie nazwy, dla grupy adresów, listy dystrybucyjnej utworzy, a następnie wyświetli ją na ekranie użytkownika.
Sub zrob_liste_dla_zaznaczonych_wiadomosci()
If Application.ActiveExplorer.CurrentFolder.DefaultItemType <> 0 Then Exit Sub
Dim Message As String, nazwa_listy As String
Message = "Podaj nazwe dla zakładanej listy dystrybucyjnej." & vbCr _
& "Wszystkie zaznaczone kontakty zostaną podłączone do tej grupy."
nazwa_listy = Trim(InputBox(Message, " Tworzenie listy dystrybucyjnej"))
nazwa_listy = Replace(nazwa_listy, ";", " ")
nazwa_listy = Replace(nazwa_listy, "(", vbNullString)
nazwa_listy = Replace(nazwa_listy, ")", vbNullString)
If Len(Trim(nazwa_listy)) = 0 Then Exit Sub
Dim oContactFolder As MAPIFolder
Dim oDistList As DistListItem
Dim oMailItem As MailItem
Dim oRecipients As Recipients
Dim oRecipient As Recipient
Dim item As MailItem
Dim oNewContact As ContactItem
Set oContactFolder = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts)
Set oDistList = oContactFolder.Items.Add(olDistributionListItem)
With oDistList
.DLName = nazwa_listy
.Save
End With
Dim MailAdres, oReply, oRecipients2, oRecip
Dim adresy$, adres$
Dim NoDupes As New Collection
Dim I As Long, J As Long
Dim Swap1, Swap2
On Error GoTo ErrMessage
For Each item In Application.ActiveExplorer.Selection
DoEvents
Set MailAdres = item
Set oReply = item.Reply
Set oRecipients2 = oReply.Recipients
'adresy DO
For Each oRecip In oRecipients2
NoDupes.Add oRecip.Address
Next
'adresy DW – można wyłączyć
For I = 1 To MailAdres.Recipients.Count
NoDupes.Add MailAdres.Recipients(I).Address
Next I
Next
Set MailAdres = Nothing
Set oReply = Nothing
Set oRecipients2 = Nothing
For I = 1 To NoDupes.Count - 1
DoEvents
For J = I + 1 To NoDupes.Count
If NoDupes(I) > NoDupes(J) Then
Swap1 = NoDupes(I)
Swap2 = NoDupes(J)
NoDupes.Add Swap1, Before:=J
NoDupes.Add Swap2, Before:=I
NoDupes.Remove I + 1
NoDupes.Remove J + 1
End If
Next J
Next I
Set oDistList = oContactFolder.Items(nazwa_listy)
Set oMailItem = Application.CreateItem(olMailItem)
Set oRecipients = oMailItem.Recipients
adres = ""
For J = 1 To NoDupes.Count
DoEvents
If adres = NoDupes(J) Then GoTo nastepny
oRecipients.Add NoDupes(J)
'adresy = adresy & NoDupes(J) & ";"
adres = NoDupes(J)
nastepny:
Next J
'Debug.Print adresy
oRecipients.ResolveAll
With oDistList
.AddMembers oRecipients
.Save
.Display 0 'można wyłączyć
End With
ErrExit:
On Error Resume Next
Set oDistList = Nothing
Set oMailItem = Nothing
Set oRecipients = Nothing
Exit Sub
ErrMessage:
MsgBox "Błąd procedury " & Err.Number & vbCr _
& Err.Description, vbExclamation, " Informacja o błędzie"
Goto ErrExit
End Sub
Aby osadzić procedurę zrob_liste_dla_zaznaczonych_wiadomosci pod przyciskiem w menu MS Outlook polecam uwadze następujący artykuł.
Postępowanie krokowe w makra:
Jeśli masz pytania dotyczące makra zobacz powiązany z nim wątek na naszym forum.