How to not duplicate calendar appointments? - vba

Question

I found VBA code that checks my schedule and creates an all-day 'busy' appointment if I exceed a certain amount of time in meetings on a given day.
The code works, but creates a duplicate event each time it runs.
I want to add a condition to see if an event already exists with the subject line "%hours of appt today" to prevent duplicate calendar events.
Sub BlockMoreCalendarAppts()
Dim myAcct As Outlook.Recipient
Dim myFB As String
Dim tDate As Date
Dim d As Long
Dim i As Long
Dim test As String
Dim oAppt As AppointmentItem
' it needs to know whose FB to check. Set this as your email address
Set myAcct = Session.CreateRecipient("myemailaddress")
' days to check (checks calendar for (7) days from todays date)
For d = 0 To 7
tDate = Date + d
' use start of working day or there about
' false counts tenetive and oof as busy
myFB = myAcct.FreeBusy(tDate + #7:30:00 AM#, 5, False)
' this gets the # of 5 min periods before the start time
i = (TimeValue(tDate + #7:30:00 AM#) * 288)
' only count free busy for 9 hours from start + at least 1 additional 5 min period
' (in my example, my day starts at 7:30 and ends at 4:30, so counting 9 hours)
' # of min in working day / 5
' skips busy times in the evening
test = Mid(myFB, i, 545 / 5)
CountOccurrences = UBound(Split(test, "1")) 'busy, oof or tentative
CountO = UBound(Split(test, "0")) ' free
'round to hours for subject
times = Round(((CountOccurrences * 5) / 60), 2)
' create all day busy event when I am scheduled
' to be in meetings for 5 or more hours per day
' there are 12 5 minute periods per hour
' 60 = 5 hours, 48 = 4 hours, 72 = 6 hours
If CountOccurrences >= 60 Then
' check to make sure an all day event wasn't already created
' to mark a day as busy
' default calendar
Set oAppt = Application.CreateItem(olAppointmentItem)
With oAppt
.Subject = times & " hours of appt today"
.Start = tDate
.ReminderSet = False
.Categories = "Full Day"
.AllDayEvent = True
.BusyStatus = olBusy
.Save
End With

Answer 1

I am using this code to search for appointments on a specific date and with a specific subject.
Public objCalendar As Outlook.folder
Public CalendarItems As Outlook.Items
Public oAppt As Outlook.AppointmentItem
Function Calendar_ApptExists(appt_Date As Date, appt_subject$) As Boolean
Set objCalendar = Session.GetDefaultFolder(olFolderCalendar)
Set CalendarItems = objCalendar.Items
' Items in calendar
Debug.Print "Items in Calendar: " & CalendarItems.Count
' Search calendar
For Each oAppt In CalendarItems
Debug.Print oAppt.Start, oAppt.Subject
' Check is appointment already exists
If (Int(oAppt.Start) = appt_Date) And oAppt.Subject = appt_subject Then
MsgBox "Already exists an appointment with '" & oAppt.Subject & "'", vbExclamation
Calendar_ApptExists = True
Exit Function
End If
Next
End Function

Answer 2

The code works, but creates a duplicate event each time it runs.
That is because in the code you create a new appointment item:
' default calendar
Set oAppt = Application.CreateItem(olAppointmentItem)
With oAppt
.Subject = times & " hours of appt today"
.Start = tDate
.ReminderSet = False
.Categories = "Full Day"
.AllDayEvent = True
.BusyStatus = olBusy
.Save
End With
Instead, you need to use Find/FindNext or Restrict methods of the Items class to find any appointment for the specified time frame. Read more about these methods in the following articles:
How To: Retrieve Outlook calendar items using Find and FindNext methods
How To: Use Restrict method in Outlook to get calendar items