Option Explicit
Public Sub CreateDeleteAppointments()
ActiveSheet.Select
On Error GoTo Err_Execute
Dim olNs As Object 'Outlook.Namespace
Dim olApp As Object 'Outlook.Application
Dim olAppt As Object 'Outlook.AppointmentItem
Dim blnCreated As Boolean
Dim CalFolder As Object 'Outlook.MAPIFolder
Dim CalItems As Object 'Outlook.Items
Dim ResItems As Object 'Outlook.Items
Dim sFilter, strSubject As String
Dim itm As Object
Dim dtStart, dtEnd As Date
Dim i As Long
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
If Err.Number <> 0 Then
Set olApp = CreateObject("Outlook.Application")
blnCreated = True
Err.Clear
Else
blnCreated = False
End If
On Error GoTo 0
Set olNs = olApp.GetNamespace("MAPI")
Set CalFolder = olNs.GetDefaultFolder(9)
Set CalItems = CalFolder.Items
CalItems.Sort "[Start]"
i = 2
Do Until Trim(Cells(i, 1).Value) = ""
If Cells(i, 7).Value = "Delete" Then
' create search string to find events to delete
strSubject = Cells(i, 5)
dtStart = Cells(i, 1) + Cells(i, 3)
dtEnd = Cells(i, 2) + Cells(i, 4)
'create the Restrict filter by day and recurrence"
sFilter = "[Start] = '" & dtStart & "' And [End] = '" & dtEnd & "' And [Subject] = """ & strSubject & """"
'Debug.Print sFilter
Set ResItems = CalItems.Restrict(sFilter)
'Debug.Print ResItems.Count
'Loop through the items in the collection.
For Each itm In ResItems
itm.Delete
Next
Else
Set olAppt = CalFolder.Items.Add(1)
With olAppt
'Define calendar item properties
.Start = Cells(i, 1) + Cells(i, 3)
.End = Cells(i, 2) + Cells(i, 4)
.Subject = Cells(i, 5)
'.Location = Cells(i, 2)
' .Body = Cells(i, 3)
If Cells(i, 7).Value = "x" Then
.AllDayEvent = True
End If
.BusyStatus = olFree
' .ReminderMinutesBeforeStart = Cells(i, 9)
'.ReminderSet = True
.Categories = Cells(i, 9)
.Save
' For meetings or Group Calendars
' .Send
End With
End If
i = i + 1
Loop
Set olAppt = Nothing
Set olApp = Nothing
Exit Sub
Err_Execute:
MsgBox "An error occurred - Exporting items to Calendar."
End Sub
