Einfügen einer oder aller Adresse(n) aus dem Outlook-Adressbuch in ein Word-Dokument

Um Einzeladressen von Outlook nach Word einzufügen gibt es den Befehl „EinfügenAdresse“ bzw. die Möglichkeit einer besseren Formatierung mit Datenfeldern und Autotext. Für weiterreichende Möglichkeiten muss man aber leider noch immer anders vorgehen. Der Code in der schon etwas älteren OutlAdr.dot von http://www.pcwelt.de/downloads/office/word-tools/20031/outladrdot/ verursachte bei mir einen Fehler. Da er jedoch bereits mit dem aktuell gültigen VBA geschrieben wurde vermutete ich, dass nur ein paar Zeilen geändert oder hinzugefügt werden müssten um diesen zu beheben. Ergebnis: Es fehlte eine Prüfung, ob es sich beim jeweiligen Eintrag im Kontakteordner um einen Kontakt oder eine Verteilerliste handelt. Nachfolgend der ergänzte Code (um den lästigen Sicherheitshinweis von Outlook bei Zugriff eines Programms einzustellen verwendet man am Besten das kostenlose „Advanced Security for Outlook“):

Code:

Private Sub GetAddressList(myIndex As Integer)
    Dim i As Integer
    Const olFolderContacts = 10
    
    Dim myContactList() As String
    Set ol = CreateObject("Outlook.Application")
    Set nsmapi = ol.GetNamespace("MAPI")
    'Nächste Zeile bezieht sich auf den Standardordner Kontakte
    Set myFolder = nsmapi.GetDefaultFolder(olFolderContacts)
    'es geht aber auch mit jedem anderem Ordner
    'Set myFolder = nsmapi.GetDefaultFolder(olFolderContacts).Folders("Testkontakte")
    'Set myFolder = nsmapi.Folders("Persönliche Ordner").Folders("AlteKontakte")
    NumItems = myFolder.items.Count
    ReDim myContactList(NumItems)
   Set MyItems = myFolder.items
   Select Case myIndex
   
   Case 0
   For i = 1 To NumItems
     Set MyItem = MyItems.Item(i)
    If UCase(Left(MyItem.MessageClass, 11)) = "IPM.CONTACT" Then
     myContactList(i) = MyItems(i).Lastname + "," + MyItems(i).FirstName + Str(i)
    End If
   Next
     WordBasic.SortArray myContactList()
   For i = 1 To NumItems
     Set MyItem = MyItems.Item(i)
    If UCase(Left(MyItem.MessageClass, 11)) = "IPM.CONTACT" Then
     lstName.AddItem (myContactList(i))
    End If
   Next
   
   Case Is > 0
    InsertIntoDoc (MyItems(myIndex).FirstName + " " + MyItems(myIndex).Lastname)
    InsertIntoDoc (MyItems(myIndex).BusinessAddress)
    InsertIntoDoc (MyItems(myIndex).Email1Address)
        
   Case -1
 
 For i = 1 To NumItems
    Set MyItem = MyItems.Item(i)
   If UCase(Left(MyItem.MessageClass, 11)) = "IPM.CONTACT" Then
    InsertIntoDoc (MyItems(i).FirstName + " " + MyItems(i).Lastname)
    InsertIntoDoc (MyItems(i).BusinessAddress)
    InsertIntoDoc (MyItems(i).Email1Address)
   End If
 Next
    
 End Select

Set nsmapi = Nothing
Set ol = Nothing
Set MyItem = Nothing
End Sub