Help Using VBA To Get Calendar Item Count

[cassfutbol]

I am trying to count the number of appointments I have in my calendar for the current day.

I have this code:

Dim objOlkApp As Object
Dim olkNS As Outlook.NameSpace
Dim fldrCalendar As Outlook.Folder
Dim fldrMyFolder As Outlook.Folder
Dim olkItems As Outlook.Items
Dim olkFilterItems As Outlook.Items
Dim strFilter As String
Dim dteToday As Date
Dim dteYesterday As Date

dteToday = Date
dteYesterday = Date - 1

Set objOlkApp = CreateObject("Outlook.Application")
Set olkNS = objOlkApp.GetNamespace("MAPI")
Set fldrCalendar = olkNS.GetDefaultFolder(olFolderCalendar)
Set olkItems = fldrCalendar.Items

strFilter = "[Start] <= '" & Format(dteToday & " 11:59pm", "ddddd h:nn AMPM") & _
"' And [End] >= '" & Format(dteYesterday & " 11:59pm", "ddddd h:nn AMPM") & "'"

olkItems.Find (strFilter)
olkItems.Sort "[Start]", False
olkItems.IncludeRecurrences = False

Set olkFilterItems = olkItems.Restrict(strFilter)

This code returns 16 items. I have 3 items on my calendar today. 2 are recurring appointments and 1 is just for today.

If I use an if statement to check if the the [IsRecurring] flag is set and don't include it, I only get 1 item.

How can I get a count for just today that includes only the recurring items listed today, and also get items that are not recurring but in the calendar for today?

Thanks!

[cassfutbol]

I have figured out my issue. For anyone who wants to see the code it is below.


Sub Check_Daily_Calendar()
Dim objOlkApp As Object
Dim olkNS As Outlook.NameSpace
Dim fldrCalendar As Outlook.Folder
Dim olkItems As Outlook.Items
Dim strFilter As String
Dim dteToday As Date
Dim dteYesterday As Date
Dim lngCount As Long
Dim intCoreHourCount As Integer
Dim intHolidayCount As Integer
Dim dteStartDate As Date
Dim strMessage As String
Dim aryMeetingTimes() As String
Dim intArrayCount As Integer
Dim intTotalCount As Integer
Dim myCurrAppItem As Outlook.AppointmentItem


dteToday = Date
dteYesterday = Date - 1

Set objOlkApp = CreateObject("Outlook.Application")
Set olkNS = objOlkApp.GetNamespace("MAPI")
Set fldrCalendar = olkNS.GetDefaultFolder(olFolderCalendar)
Set olkItems = fldrCalendar.Items
olkItems.Sort "[Start]", False
olkItems.IncludeRecurrences = True

strFilter = "[Start] <= '" & Format(dteToday & " 11:59pm", "ddddd h:nn AMPM") & _
"' And [Start] >= '" & Format(dteYesterday & " 11:59pm", "ddddd h:nn AMPM") & "'"

Set myCurrAppItem = olkItems.Find(strFilter)
intTotalCount = 0

While TypeName(myCurrAppItem) <> "Nothing"
intTotalCount = intTotalCount + 1
Set myCurrAppItem = olkItems.FindNext
Wend

ReDim aryMeetingTimes(intTotalCount)
Set myCurrAppItem = olkItems.Find(strFilter)

intCoreHourCount = 0
intHolidayCount = 0
intArrayCount = 0

While TypeName(myCurrAppItem) <> "Nothing"
dteStartDate = Format(myCurrAppItem.Start, "h:nn AMPM")

If dteStartDate >= "08:00 AM" And dteStartDate <= "05:00 PM" Then
intCoreHourCount = intCoreHourCount + 1
aryMeetingTimes(intArrayCount) = dteStartDate
intArrayCount = intArrayCount + 1
Else
If myCurrAppItem.Categories = "Holiday" Then
intHolidayCount = intHolidayCount + 1
Else
aryMeetingTimes(intArrayCount) = dteStartDate
intArrayCount = intArrayCount + 1
End If
End If

Set myCurrAppItem = olkItems.FindNext
Wend
strMessage = "Good Morning Kent!" & vbCr & vbCr & _
"you have " & intCoreHourCount & " business meetings today."

If intTotalCount - intCoreHourCount - intHolidayCount > 0 Then
strMessage = strMessage & vbCr & vbCr & "You have " & _
intTotalCount - intCoreHourCount - intHolidayCount & _
" off core hour meetings."
End If

lngCount = 0

If intArrayCount > 0 Then
strMessage = strMessage & vbCr & vbCr & "Meeting times are: "
Do While lngCount < intArrayCount
strMessage = strMessage & vbCr & vbTab & aryMeetingTimes(lngCount)
lngCount = lngCount + 1
Loop

End If

MsgBox (strMessage)

' Cleanup memory

Set objOlkApp = Nothing
Set olkNS = Nothing
Set fldrCalendar = Nothing
Set olkItems = Nothing
Set myCurrAppItem = Nothing
ReDim aryMeetingTimes(0)

End Sub