VBATools

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.

Option Explicit
Sub zrob_liste_dla_zaznaczonych_wiadomosci()
'MVP OShon from VBATools.pl
If Application.ActiveExplorer.CurrentFolder.DefaultItemType <> 0 Then Exit Sub
Dim Message As String, nazwa_listy As String
Message = "Podaj nazwę 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:

• 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.

(c) Shon Oskar – www.VBATools.pl