VBA Tools

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.

Wszelkie prawa zastrzeżone. Żadna część ani całość tego artykułu nie może być powielana ani publikowana bez zgody autora.