BETA
Aby się zalogować, najpiew wybierz portal.
Aby się zarejestrować, najpiew wybierz portal.
Podaj słowa kluczowe
Słowa kluczowe muszą mieć co najmniej 3 sąsiadujące znaki alfanumeryczne
Pole zawiera niedozwolone znaki

Baza wiedzy











Porada

02-03-2011 22:24 | Oskar Shon
Outlook: 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.

Option Explicit
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

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 VBATools.pl"
Goto ErrExit
End Sub

Podobne artykuły

Komentarze 0

pkt.

Zaloguj się lub Zarejestruj się aby wykonać tę czynność.