VBATools

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.

Option Explicit
Sub Tworzenie_list_dystrybucyjnych()
'MVP OShon from VBATools.pl
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. Należy wiedzieć iż stosowanie list dystrybucyjnych może prowadzić do blokady konta przez administratorów serwerów. Aby tak się nie stało polecam stosowanie rozwiązania umożliwiającego wysyłanie wiadomości pojedynczo (z listy dystrybucyjnej).

(c) Shon Oskar – www.VBATools.pl