VBATools

Export członków listy dystrybucyjnej do Excela

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

XL_Referencje_Outlook

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.

:, , , , ,

1 Comment for this entry

Leave a Reply

Recently Active Members

Profile picture of vbatools
Profile picture of Karol Stilger
Profile picture of marcinmachalowski
Profile picture of Joanna Subik
Profile picture of Anorak
Profile picture of programistaaccess
Profile picture of piotrpawlik
Profile picture of Emil Wasilewski
Profile picture of kicekpicek
Profile picture of coldfusion
Profile picture of Gosia Borzęcka
Profile picture of lukaszch
Profile picture of itadministracja
Profile picture of farbenia
Profile picture of Łukasz Kałużny
Profile picture of kabzinski
Profile picture of rtynski
Profile picture of leszekbetlinski
Profile picture of Iv
Profile picture of Justyna Spychała