Automatisch in je agenda plaatsen

Option Explicit

Private Sub CommandButton1_Click()
    Dim outApl As Outlook.Application
    Dim outItem As Outlook.AppointmentItem
    Dim objNameSpace As Namespace
    Dim objFolder As Folder
    Dim intItems As Integer
    Dim intPers As Integer
    Dim blnOutlook As Boolean
    Dim shtItems As Worksheet
    Dim shtPers As Worksheet
    
    Set shtItems = Sheets("Blad1")
    Set shtPers = Sheets("Naar agenda")
    
    On Local Error Resume Next
    Set outApl = GetObject(, "Outlook.Application")
    If Err Then
        blnOutlook = True
        Set outApl = CreateObject("Outlook.Application")
    End If
    
    Set objNameSpace = outApl.GetNamespace("MAPI")
    Set objFolder = objNameSpace.GetDefaultFolder(olFolderCalendar)
    objFolder.Display
    
    intItems = 5
    
    While Not IsEmpty(shtItems.Cells(intItems, 2))
        Set outItem = outApl.CreateItem(olAppointmentItem)
    
        With outItem
            .Subject = shtItems.Cells(intItems, 1).Value
            .Location = shtItems.Cells(intItems, 2) & " " & shtItems.Cells(intItems, 3)
            .Start = shtItems.Cells(intItems, 4)
            .AllDayEvent = True
            .Body = shtItems.Cells(intItems, 5)
            
            intPers = 1
            
            While Not IsEmpty(shtPers.Cells(intPers, 1))
                If StrComp(shtPers.Cells(intPers, 3).Value, "Ja", vbTextCompare) = 0 Then
                    .Recipients.Add shtPers.Cells(intPers, 2)
                    
                End If
                intPers = intPers + 1
            Wend
            .Send
        End With
        intItems = intItems + 1
    Wend
    
    objFolder.Delete
    Set objFolder = Nothing
    Set outItem = Nothing
    Set objNameSpace = Nothing
    If blnOutlook Then
        Set outApl = Nothing
        outApl.Quit
    End If
End Sub