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")
Set olDlg = olApp.Session.GetSelectNamesDialog
Set olAddrList = olNS.AddressLists("Kontakte (Nur dieser Computer)")
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)
Set olAddressEntry = olRecipient.AddressEntry
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