Tworzenie listy dystrybucyjnej dla podanych adresów email

Microsoft Outlook nie posiada mechanizmu, dzięki któremu możemy wkleić kilka adresów email osadzonych w pamięci, z których byłaby utworzona lista dystrybucyjna. Zwykle proces ten jest realizowany adres po adresie w kreatorze listy, poprzez wybranie adresata lub wpisanie pojedynczego adresu.

Poniższa procedura po wklejeniu co najmniej dwóch adresów email oddzielonych znakiem „;” w wyświetlonym oknie i podaniu nazwy listy dystrybucyjnej utworzy ją, a następnie wyświetli ją na ekranie użytkownika.

Sub Tworzenie_list_dystrybucyjnych()

Dim Message$, nazwa_listy$, Adresy$, x&

Message = "Wklej adresy Email rozdzielnone znakiem '';''"
Adresy = Trim(InputBox(Message, " Tworzenie listy dystrybucyjnej"))

If Len(Adresy) > 0 Then
On Error GoTo blad
    If InStr(1, Adresy, ";") > 0 Then
   
    Message = "Podaj nazwę dla zakładanej listy dystrybucyjnej." & vbCr _
            & "Wszystkie poprawne adresy 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(nazwa_listy) = 0 Then GoTo nie_podano_nazwy
      
    Dim oContactFolder As MAPIFolder
    Dim oDistList As DistListItem
    Dim oMailItem As MailItem
    Dim oRecipients As Recipients
    Dim oRecipient As Recipient
               
    Set oContactFolder = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts)
    Set oDistList = oContactFolder.Items.Add(olDistributionListItem)
    With oDistList
        .DLName = nazwa_listy
        .Save
    End With
   
    Set oDistList = oContactFolder.Items(nazwa_listy)
    Set oMailItem = Application.CreateItem(olMailItem)
    Set oRecipients = oMailItem.Recipients
   
    Dim temp() As String, abc&
    abc = 0
    temp() = Split(Left$(Adresy, Len(Adresy) - 1), ";")
    While (abc <= UBound(temp()))
       If temp(abc) Like "*@*.*" Then
          oRecipients.Add (temp(abc))
          x = x + 1
       End If
       abc = abc + 1
    Wend
   
    oRecipients.ResolveAll
   
    If x > 0 Then
        With oDistList
            .AddMembers oRecipients
            .Save '<-jeśli chcesz zapisać
            .Display 0 '<-jeśli chcesz wyświetlić
        End With
    Else
        oDistList.Delete
    End If
   
    Set oDistList = Nothing
    Set oMailItem = Nothing
    Set oRecipients = Nothing
    Else
brak_conajmniej_2:
    MsgBox "Lista dystrybucyjna nie została utworzona." & vbCr _
         & "Aby utworzyć Listę dystrybucyjną należy podać wkleić" & vbCr _
         & "conajmniej 2 adresy rozdzielone znakiem '';''.", vbExclamation, " Informacja o błędzie"
    End If
Else
GoTo brak_conajmniej_2
End If
Exit Sub

nie_podano_nazwy:
  MsgBox "Lista dystrybucyjna nie została utworzona." & vbCr _
       & "Aby utworzyć Listę dystrybucyjną należy" & vbCr _
       & "podać nazwe dla grupy odbiorców.", vbExclamation, " Informacja o błędzie"
Exit Sub

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

End Sub

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

Postępowanie krokowe w makro:

• sprawdza, czy jest wpisane co najmniej 2 pozycje rozdzielone znakiem „;”
• tworzy listę dystrybucyjną o nazwie, jaka została podana w InputBoxie
• sprawdza czy podany adres zawiera znak małpy oraz co najmniej 1 kropkę
• dodaje adresy do utworzonej wcześniej listy dystrybucyjnej i zapisuje zmiany
• pokazuje efekt końcowy, otwierając listę dystrybucyjną (można wyłączyć)

Podobna procedura „zrob_liste_dla_zaznaczonych_wiadomosci” dostępna jest tutaj.