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











Outlook: Eksport członków listy dystrybucyjnej do Excela

07-06-2011 06:00 | Oskar Shon
Jak ograniczyć ilość członków listy dystrybucyjnej w Outlooku? Na to pytanie postaram się odpowiedzieć w poniższym artykule.

Jak ograniczyć ilość członków listy dystrybucyjnej w Outlooku?
Na to pytanie postaram się odpowiedzieć w poniższym artykule.

Po utworzeniu listy dystrybucyjnej w Outlooku nie ma możliwości pobrania adresów w niej zawartych. Co za tym idzie, utworzyć nową listę ograniczając ilość ich członków. Czynność tą można zrealizować na dwa sposoby: z Excela łącząc się z Outlookiem oraz z Outlooka, budując nowy skoroszyt w MS Excel. Dla podanej z nazwy listy dystrybucyjnej, poniższe makra eksportują adresy email członków do arkusza Excela wraz z ich opisem. Aby przypisać ponownie część adresów do nowej listy polecam metodę opisaną w artykule: Tworzenie listy dystrybucyjnej dla podanych adresów email.

Procedura do zastosowania w MS Outlook:

Sub ExtractDistLists()
Const proces = "Export członków listy dystrybucyjnej"
Dim oFolder As MAPIFolder, strDistListNames$, strDistListMembers As New Collection, x&
Dim oDistList As DistListItem, nIndex&, oDistListFound As Boolean, item As Object, ext As Variant
Set oFolder = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts)

strDistListNames = InputBox("Podaj nazwę listy dystrybucyjnej.", proces)
For Each item In oFolder.Items
If item.Class = 69 Then
Set oDistList = item
If oDistList.DLName = strDistListNames Then
oDistListFound = True
For nIndex = 1 To oDistList.MemberCount
strDistListMembers.Add oDistList.GetMember(nIndex).Address & _
";" & oDistList.GetMember(nIndex).Name
Next
End If
End If
Next

If oDistListFound = False Then
If Len(strDistListNames) = 0 Then
MsgBox "Nie podano nazwy listy dystrybucyjnej." & vbCr & _
"Procedura została przerwana!", _
vbExclamation, proces & " VBATools.pl"
Else
MsgBox "Nie znaleziono listy dystrybucyjnej o nazwie " & _
Chr(34) & strDistListNames & Chr(34), _
vbCritical, proces & " VBATools.pl"
End If
Else
ext = MsgBox("Pobrano " & strDistListMembers.Count & " adresów. " & _
"Czy wyeksportować je do pliku Excela?", _
vbYesNo + vbQuestion, proces & " VBATools.pl")
If ext = vbYes Then
Dim xlApp As Object, xlWkb As Object
Set xlApp = CreateObject("Excel.Application")
With xlApp
.Visible = True
Set xlWkb = .Workbooks.Add(1)
End With
For x = 1 To strDistListMembers.Count
With xlWkb.Worksheets(1).Cells(x, 1)
.value = Split(strDistListMembers(x), ";")(0)
.Offset(, 1) = Split(strDistListMembers(x), ";")(1)
End With
Next x
End If
End If

Set xlWkb = Nothing
Set xlApp = Nothing
Set oDistList = Nothing
Set oFolder = Nothing
End Sub

Procedura do zastosowania w MS Excel:

Sub ExtractDistLists_XL()
Const proces = "Export członków listy dystrybucyjnej"
Dim oFolder As MAPIFolder, strDistListNames$, strDistListMembers As New Collection, OutApp As Object
Dim oDistList As DistListItem, nIndex&, oDistListFound As Boolean, item As Object, ext As Variant, x&

Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set oFolder = OutApp.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts)

strDistListNames = "Klienci" 'nazwa listy dystrybucyjnej
For Each item In oFolder.Items
If item.Class = 69 Then
Set oDistList = item
If oDistList.DLName = strDistListNames Then
oDistListFound = True
For nIndex = 1 To oDistList.MemberCount
strDistListMembers.Add oDistList.GetMember(nIndex).Address & _
";" & oDistList.GetMember(nIndex).Name
Next
End If
End If
Next

If oDistListFound = False Then
If Len(strDistListNames) = 0 Then
MsgBox "Nie podano nazwy listy dystrybucyjnej." & vbCr & _
"Procedura została przerwana!", _
vbExclamation, proces & " VBATools.pl"
Else
MsgBox "Nie znaleziono listy dystrybucyjnej o nazwie " & _
Chr(34) & strDistListNames & Chr(34), _
vbCritical, proces & " VBATools.pl"
End If
Else
ext = MsgBox("Pobrano " & strDistListMembers.Count & " adresów. " & _
"Czy wyeksportować je do pliku Excela?", _
vbYesNo + vbQuestion, proces & " VBATools.pl")
If ext = vbYes Then
Workbooks.Add
For x = 1 To strDistListMembers.Count
With Cells(x, 1)
.value = Split(strDistListMembers(x), ";")(0)
.Offset(, 1) = Split(strDistListMembers(x), ";")(1)
End With
Next x
End If
End If

Set oDistList = Nothing
Set oFolder = Nothing
Set OutApp = Nothing
End Sub

Jeśli procedura będzie realizowana z poziomu Excela, dobrze jest dodać referencje do posiadanej wersji Outlooka.

Praktyczne rozwiązania dla składników pakietu MS Office. Business Developer w dz. Kontroli wew. i Optymalizacji Veracomp SA Właściciel VBATools.pl, Moderator Outlook.pl

Podobne artykuły

Komentarze 0

pkt.

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