Outlooktermine aus Excel erstellen

Sub CreateOutlookAppointments()

    Dim olApp As Outlook.Application

    Dim olAppt As Outlook.AppointmentItem

    Dim olRecip As Outlook.Recipient

    Dim olAttendees As Outlook.Recipients

    Dim olOptionalAttendees As Outlook.Recipients

    Dim olAttach As Outlook.Attachment

    Dim i As Long

    

    Set olApp = New Outlook.Application

    

    'Get the active worksheet in Excel

    Dim ws As Worksheet

    Set ws = ActiveSheet

    

    'Loop through the rows in the worksheet and create appointments

    For i = 2 To ws.Cells(Rows.Count, "A").End(xlUp).Row

        

        'Create a new appointment item

        Set olAppt = olApp.CreateItem(olAppointmentItem)

        

        'Set the appointment details

        olAppt.Subject = ws.Cells(i, 1).Value

        olAppt.Location = ws.Cells(i, 2).Value

        olAppt.Start = ws.Cells(i, 3).Value

        olAppt.Duration = ws.Cells(i, 4).Value

        olAppt.ReminderSet = True

        olAppt.ReminderMinutesBeforeStart = 15

        

        'Add required attendees

        Set olAttendees = olAppt.Recipients

        For Each cell In Split(ws.Cells(i, 5).Value, ";")

            Set olRecip = olAttendees.Add(cell)

            olRecip.Type = olTo

        Next

        

        'Add optional attendees

        Set olOptionalAttendees = olAppt.Recipients

        For Each cell In Split(ws.Cells(i, 6).Value, ";")

            Set olRecip = olOptionalAttendees.Add(cell)

            olRecip.Type = olOptional

        Next

        

        'Add attachment to the appointment

        If Len(ws.Cells(i, 7).Value) > 0 Then

            Set olAttach = olAppt.Attachments.Add(ws.Cells(i, 7).Value)

        End If

        

        'Send the appointment

        olAppt.Send

        

        'Release the attachment object

        If Not olAttach Is Nothing Then

            Set olAttach = Nothing

        End If

        

    Next

    

    'Release objects from memory

    Set olOptionalAttendees = Nothing

    Set olAttendees = Nothing

    Set olRecip = Nothing

    Set olAppt = Nothing

    Set olApp = Nothing

    

End Sub