Microsoft Outlook troubleshooting

Po utworzeniu listy dystrybucyjnej w programie MS Outlook nie ma możliwości pobrania adresów w niej zawartych, a co za tym idzie, brak możliwości utworzenia nowej listy w oparciu o starą (np. ograniczając ilość jej członków).

Czynność tą można zrealizować na dwa sposoby: z poziomu Excela łącząc się z Outlookiem oraz z poziomu Outlooka, budując nowy skoroszyt w MS Excel.

Dla podanej nazwy listy dystrybucyjnej, poniższe makra eksportują adresy email jej 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

Osadzenie procedury można znaleźć w artykule: Instalacja i uruchamianie makr .

 

MVP Shon Oskar – VBATools.pl
Jeśli masz pytania dot. tego artykułu zapraszam na Forum
Skonfiguruj swój pakiet dodatków do Excela, Worda, PowerPointa i Outlooka



© Wszelkie prawa zastrzeżone. Żadna część ani całość tego artykułu nie może być powielana ani publikowana bez zgody autora.