Export członków listy dystrybucyjnej do Excela
by vbatools on Apr.07, 2011, under Excel, Outlook, Porady
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()
'MVP OShon from VBATools.pl
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()
'MVP OShon from VBATools.pl
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.
Rys 1. Podłączenie referencji Excela dla wczesnego wiązania
Gdyby była konieczność eksportu wszystkich kontaktów, ze wszystkich list dystrybucyjnych to proponuje takie rozwiązanie (z developera MS Outlook)
Sub ExtractAllDistLists() 'MVP OShon from VBATools.pl Const proces = "Export wszystkich członków listy dystrybucyjnej" Dim oFolder As MAPIFolder, strDistListNames$, strDistListMembers As New Collection, x& Dim oDistList As DistListItem, nIndex&, item As Object, ext As Variant Set oFolder = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts) For Each item In oFolder.Items If item.Class = 69 Then Set oDistList = item For nIndex = 1 To oDistList.MemberCount strDistListMembers.Add oDistList.DLName & _ ";" & oDistList.GetMember(nIndex).Address & _ ";" & oDistList.GetMember(nIndex).Name Next End If Next If strDistListMembers.Count > 0 Then ext = MsgBox("Pobrano " & strDistListMembers.Count & " adresów. " & _ "Czy wyeksportować rekordy 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 .Application.ScreenUpdating = False 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) .Offset(, 2) = Split(strDistListMembers(x), ";")(2) End With Next x xlApp.Application.ScreenUpdating = True End If Else MsgBox "Nie znaleziono list dystrybucyjnych", _ vbCritical, proces & " VBATools.pl" End If Set xlWkb = Nothing Set xlApp = Nothing Set oDistList = Nothing Set oFolder = Nothing End Sub
(c) Shon Oskar – www.VBATools.pl
Wszelkie prawa zastrzeżone. Żadna część ani całość tego artykułu nie może być powielana ani publikowana bez zgody autora.
April 7th, 2011 on 10:45
Wielkie dzięki, za ten artykuł.
pozdrawiam serdecznie
golly