Sub
Outlook_Liefertermin()
Dim
oApp
As
New
Outlook.Application
Dim
oNamespace
As
Outlook.
Namespace
Dim
oEmpfang
As
Outlook.Recipient
Dim
oOrdner
As
Outlook.Folder
Dim
oTermin
As
Outlook.AppointmentItem
Set
oNamespace = oApp.GetNamespace(
"MAPI"
)
Set
oEmpfang = oNamespace.CreateRecipient(
"FestEvent, WB"
)
oEmpfang.Resolve
If
oEmpfang.Resolved =
False
Then
MsgBox
"Empfänger wurde nicht gefunden"
, vbCritical,
"Fehler"
Exit
Sub
End
If
Set
oOrdner = oNamespace.GetSharedDefaultFolder(oEmpfang, olFolderCalendar)
Set
oTermin = oOrdner.Items.Add(olAppointmentItem)
With
oTermin
.Display
.MeetingStatus = olMeeting
.Subject = Tabelle2.Range(
"C12"
).Value
.RequiredAttendees = Tabelle2.Range(
"C5"
).Value
.Start = Tabelle2.Range(
"F7"
).Value
.
End
= Tabelle2.Range(
"F8"
).Value
.Location = Tabelle2.Range(
"C9"
).Value
.AllDayEvent =
True
.ReminderMinutesBeforeStart = 1440
.Body = Tabelle2.Range(
"C31"
).Value
End
With
End
Sub