Alle Verteiler erweitern

Private Sub CommandButton1_Click()

'Deklaration  
Dim OutApp As Object
Dim nspMapi As Object
Dim folMapi As Object
Dim itmAll As Object
Dim itmReal As Object
Dim itmDistList As Object
Dim strContactFilter As String
Dim excApp As Object
Dim excWkb As Object
Dim excWks As Object
Dim intRow As Integer
Dim i As Integer
Dim j As Integer
Dim k As Integer

Set OutApp = CreateObject("Outlook.Application")  
'Outlook-Objekte öffnen  
Set nspMapi = OutApp.GetNamespace("MAPI")  
'Set folMapi = nspMapi.GetDefaultFolder(olFolderContacts)  
'Ordner auswählen  
Set folMapi = nspMapi.Folders.Item("Public Folders").Folders.Item("Contacts")  
Set itmAll = folMapi.Items

'nur Verteilerlisten verwenden  
strContactFilter = "[MessageClass] = 'IPM.Distlist'"  
Set itmReal = itmAll.Restrict(strContactFilter)

'Excel-Objekte öffnen  
Set excApp = CreateObject("Excel.Application") 'Neue Excel-Instanz  
Set excWkb = excApp.Workbooks.Add 'Neues Workbook anlegen  
Set excWks = excWkb.Sheets(1) 'Erstes Sheet  

'Excel-Worksheet aufbereiten  
With excWks
  'Sheet-Name  
  .Name = "Outlook-Verteilerlisten"  
  'Spaltenüberschriften  
  .Cells(1, 1).Value = "Verteiler"  
  .Cells(1, 2).Value = "Name"  
  'Spaltenüberschriften fett  
  .Rows("1:1").Font.Bold = True  
  'Outlook-Verteilerliste nach Excel übertragen  
  intRow = 1
  
  'Excel einblenden  
  excApp.Visible = True

  For Each itmDistList In itmReal
      .Cells(intRow + 1, 1).Value = itmDistList.DLName
      j = 1
      k = 1
      For i = 1 To itmDistList.MemberCount
        If InStr(1, itmDistList.GetMember(i).Address, "@") Then  
          .Cells(intRow + k, 2).Value = itmDistList.GetMember(i).Address
          k = k + 1
        Else
          .Cells(intRow + j, 3).Value = itmDistList.GetMember(i).Name
          j = j + 1
        End If
      Next i
      intRow = intRow + WorksheetFunction.Max(k, j)
  Next itmDistList
  
  'Optimale Spaltenbreite  
  .Columns.AutoFit
End With

'Speicher freigeben  
Set itmReal = Nothing
Set itmAll = Nothing
Set folMapi = Nothing
Set nspMapi = Nothing
Set excWks = Nothing
Set excWkb = Nothing
Set excApp = Nothing

End Sub