Sub
TerminMitKontaktAuswaehlen()
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
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"
)
If
olAddrList
Is
Nothing
Then
MsgBox
"Kein Kontakte-Adressbuch 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)
If
olRecipient.Resolve
Then
On
Error
Resume
Next
Set
olContact = olNS.GetItemFromID(olRecipient.EntryID)
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
"Kontakt konnte nicht geladen werden."
, vbExclamation
End
If
Else
MsgBox
"Empfänger konnte nicht aufgelöst werden."
, vbExclamation
End
If
End
If
Else
MsgBox
"Kein Kontakt ausgewählt."
, vbInformation
End
If
End
With
End
Sub