Public Sub CreateOutlookAppt()
Dim olApp As Outlook.Application
Dim olAppt As Outlook.AppointmentItem
Dim oPattern As RecurrencePattern
Dim blnCreated As Boolean
Dim olNs As Outlook.Namespace
Dim CalFolder As Outlook.MAPIFolder
Dim subFolder As Outlook.MAPIFolder
Dim arrCal As String
Dim i As Long
Sheets(1).Select
On Error GoTo Err_Execute
On Error Resume Next
Set olApp = Outlook.Application
If olApp Is Nothing Then
Set olApp = Outlook.Application
blnCreated = True
Err.Clear
Else
blnCreated = False
End If
On Error GoTo 0
Set olNs = olApp.GetNamespace("MAPI")
Set CalFolder = olNs.GetDefaultFolder(olFolderCalendar)
i = 2
Do Until Trim(Cells(i, 1).Value) = ""
Set olAppt = CalFolder.Items.Add(olAppointmentItem)
With olAppt
.AllDayEvent = True
.start = Cells(i, 2)
.End = Cells(i, 2)
.Subject = "Verjaardag " & Cells(i, 1)
.Location = ""
.Body = "Verjaardag van " & Cells(i, 1)
.BusyStatus = olBusy
.ReminderMinutesBeforeStart = 60 * 30
.ReminderSet = True
Set oPattern = olAppt.GetRecurrencePattern
With oPattern
.PatternStartDate = Cells(i, 2)
.StartTime = TimeSerial(0, 0, 0)
.PatternEndDate = Cells(i, 2)
.EndTime = TimeSerial(0, 0, 0)
.RecurrenceType = olRecursYearly
End With
.Save
End With
i = i + 1
Loop
Set olAppt = Nothing
Set olApp = Nothing
MsgBox "Verjaardagen zijn ingelezen!", vbOKOnly
Exit Sub
Err_Execute:
MsgBox "Niet gelukt om de afspraken naar Outlook te kopiëren... :("
End Sub
