Tworzenie listy dystrybucyjnej na podstawie adresów z zaznaczonych wiadomości email

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

    oContactFolder = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts)
    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()
        MailAdres = item
        oReply = item.Reply
        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
    MailAdres = Nothing
    oReply = Nothing
    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

    oDistList = oContactFolder.Items(nazwa_listy)
    oMailItem = Application.CreateItem(olMailItem)
    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
    oDistList = Nothing
    oMailItem = Nothing
    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:

• sprawdza czy jesteś w folderze wiadomości
• tworzy listę dystrybucyjną o nazwie jaka została podana w InputBoxie
• przerzuca do tymczasowej tablicy adresy osób z pół DO i DW z zaznaczonych wcześniej wiadomości (można ograniczyć i wyłączyć to drugie)
• sortuje tą tablice aby adresy poukładane były alfabetycznie (sortowanie bąbelkowe)
• usuwa z kolekcji adresy z duplikowane (bo X zaznaczonych wiadomości może posiadać tych samych odbiorców)
• dodaje adresy do utworzonej wcześniej listy dystrybucyjnej i zapisuje zmiany
• pokazuje efekt końcowy, otwierając listę dystrybucyjną (można wyłączyć)

Jeśli masz pytania dotyczące makra zobacz powiązany z nim wątek na naszym forum.

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.