Excel Hints

Results 1 to 2 of 2

Thread: Help Using VBA To Get Calendar Item Count

  1. #1

    Question Help Using VBA To Get Calendar Item Count

    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!

  2. #2

    Smile Figured it out

    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


Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •