VBATools

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

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