Ich habe nicht behauptet das der Code funktioniert. Hier mal eine leicht angepasste Version. Zumindest bei einem kurzem Test auf dem alten Outlook hat er den kontakt aus dem Kontaktedialog ausgelesen.

Sub KontaktinformationeninTermin()
    Dim olApp As Outlook.Application
    Dim olNS As Outlook.NameSpace
    Dim olDlg As Outlook.SelectNamesDialog
    Dim olAddrList As Outlook.AddressList
    Dim olRecipients As Outlook.Recipients
    Dim olRecipient As Outlook.Recipient
    Dim olAddressEntry As Outlook.AddressEntry
    Dim olContact As Outlook.ContactItem
    Dim olAppt As Outlook.AppointmentItem
    
    Set olApp = Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")
    
    ' Kontakte-Auswahldialog öffnen
    Set olDlg = olApp.Session.GetSelectNamesDialog
    Set olAddrList = olNS.AddressLists("Kontakte (Nur dieser Computer)") ' oder "Contacts" bei engl. Version
    
    If olAddrList Is Nothing Then
        MsgBox "Adressbuch 'Kontakte' wurde nicht gefunden.", vbCritical
        Exit Sub
    End If
    
    With olDlg
        .AllowMultipleSelection = False
        .InitialAddressList = olAddrList
        .ShowOnlyInitialAddressList = True
        
        If .Display Then
            Set olRecipients = .Recipients
            If olRecipients.Count > 0 Then
                Set olRecipient = olRecipients.Item(1)
                
                ' Adresseintrag abrufen
                Set olAddressEntry = olRecipient.AddressEntry
                
                ' Versuchen, zugehörigen Kontakt abzurufen
                On Error Resume Next
                Set olContact = olAddressEntry.GetContact
                On Error GoTo 0
                
                If Not olContact Is Nothing Then
                    
                    Set olAppt = olApp.CreateItem(olAppointmentItem)
                    With olAppt
                        .Subject = "Termin mit " & olContact.FullName
                        .Body = "Kontaktinformationen:" & vbCrLf & _
                                "Name: " & olContact.FullName & vbCrLf & _
                                "E-Mail: " & olContact.Email1Address & vbCrLf & _
                                "Telefon: " & olContact.BusinessTelephoneNumber & vbCrLf & _
                                "Firma: " & olContact.CompanyName
                        .Start = Now + 1
                        .Duration = 60
                        .Display
                    End With
                Else
                    MsgBox "Der ausgewählte Eintrag ist kein Kontakt aus dem Kontakte-Ordner.", vbExclamation
                End If
            End If
        Else
            MsgBox "Vorgang abgebrochen.", vbInformation
        End If
    End With
End Sub