Code that I have so far.
Sub FindApptsInTimeFrame()
Dim myStart, myEnd As Date
Dim oCalendar As Outlook.Folder
Dim oItems As Outlook.Items
Dim oResItems As Outlook.Items
Dim oAppt As Outlook.AppointmentItem
Dim strRestriction As String
Dim strApptCategories
' Set 20 as the number of supported categories, should get that number per user's decision.
Dim strAllCategories(0 To 20) As String
Dim iTotalCount As Integer
Dim iDurationPerCategory(0 To 20) As Integer
Dim strListSep As String
Dim i, j, iNumApptCategories
Dim blnExists As Boolean
Dim dtDiff As Long
Dim fso As New FileSystemObject
' Declare a TextStream.
Dim stream As TextStream
' Create a TextStream.
Set stream = fso.CreateTextFile("C:\Users\nbksog8\test.csv", True)
'Hard-code the reporting dates just for simplicity in testing.
myStart = DateValue("11/11/2013")
myEnd = DateValue("11/15/2013")
Set oCalendar = Application.Session.GetDefaultFolder(olFolderCalendar)
'Set oItems = oCalendar.Items
Set oItems = Session.GetDefaultFolder(olFolderCalendar).Items.Parent.Folders("RUIT").Items
'Include all recurring calendar items -
'master appointments as well as recurring appointments.
oItems.IncludeRecurrences = True
oItems.Sort "[Start]"
'Specify the filter this way to include appointments that overlap
'with the specified date range but do not necessarily fall entirely within
'the date range.
'Date values in filter do not explicitly include minutes.
strRestriction = "[Start] <= '" & myEnd _
& "' AND [End] >= '" & myStart & "'"
'''Debug.Print strRestriction
'Restrict the Items collection.
Set oResItems = oItems.Restrict(strRestriction)
'Sort
oResItems.Sort "[Start]"
'Reformat myStart and myEnd to account for minutes.
myStart = #11/11/2013 7:59:00 AM#
myEnd = #11/15/2013 6:00:00 PM#
iTotalCount = 0
'Get the separator between categories from the Windows registry.
strListSep = WSHListSep()
For Each oAppt In oResItems
Debug.Print oAppt.Start & "~", oAppt.Categories & "~", oAppt.Subject & "~", oAppt.Location; "~", oAppt.Duration / 60
''''''' Open notepad to save data '''''
stream.Write ("10453770") 'Person Number
stream.Write ("~")
stream.Write (myEnd) 'Week
stream.Write ("~")
stream.Write (oAppt.Categories) 'Category
stream.Write ("~")
stream.Write (oAppt.Subject) 'Subject
stream.Write ("~")
stream.Write (oAppt.Location) 'Location
stream.Write ("~")
stream.Write (oAppt.Duration / 60) 'Time
stream.WriteLine ""
' Get the list of categories specified for this appointment.
strApptCategories = Split(oAppt.Categories, strListSep)
iNumApptCategories = UBound(strApptCategories)
' An appointment that doesn't have a category (with iNumApptCategories being 0) skips this loop.
For i = 0 To iNumApptCategories
' Check if category exists in master array strAllCategories.
blnExists = False
If iTotalCount > 0 Then
' Master array already has some categories, see if there's a match or should add category
For j = 0 To iTotalCount - 1
If Trim(strAllCategories(j)) = Trim(strApptCategories(i)) Then
blnExists = True
Exit For
End If
Next
If blnExists = False Then
' First time this category appears, add category to master array and start tallying time.
If iTotalCount >= 20 Then
MsgBox "The maximum number of categories has been reached."
GoTo Dump
End If
iTotalCount = iTotalCount + 1
strAllCategories(iTotalCount - 1) = Trim(strApptCategories(i))
' Check if the appointment is entirely within the date range.
If oAppt.Start >= myStart Then
If oAppt.End <= myEnd Then
iDurationPerCategory(iTotalCount - 1) = oAppt.Duration
Else
dtDiff = DateDiff("n", myEnd, oAppt.End)
iDurationPerCategory(iTotalCount - 1) = oAppt.Duration - dtDiff
End If
Else
dtDiff = DateDiff("n", oAppt.Start, myStart)
iDurationPerCategory(iTotalCount - 1) = oAppt.Duration - dtDiff
End If
Else
' Category already in master array, just tally the time for the category.
' Check if the appointment is entirely within the date range.
If oAppt.Start >= myStart Then
If oAppt.End <= myEnd Then
iDurationPerCategory(j) = iDurationPerCategory(j) + oAppt.Duration
Else
dtDiff = DateDiff("n", myEnd, oAppt.End)
iDurationPerCategory(j) = iDurationPerCategory(j) + oAppt.Duration - dtDiff
End If
Else
dtDiff = DateDiff("n", oAppt.Start, myStart)
iDurationPerCategory(j) = iDurationPerCategory(j) + oAppt.Duration - dtDiff
End If
End If
Else
' First category in master array of categories, start master array and start count of categories.
iTotalCount = 1
strAllCategories(0) = Trim(strApptCategories(i))
' Check if the appointment is entirely within the date range.
If oAppt.Start >= myStart Then
If oAppt.End <= myEnd Then
iDurationPerCategory(0) = oAppt.Duration
Else
dtDiff = DateDiff("n", myEnd, oAppt.End)
iDurationPerCategory(0) = oAppt.Duration - dtDiff
End If
Else
dtDiff = DateDiff("n", oAppt.Start, myStart)
iDurationPerCategory(0) = oAppt.Duration - dtDiff
End If
End If
Next
Next
'Close the file.
stream.Close
'List all unique categories and count
Dump:
' For j = 0 To iTotalCount - 1
' Debug.Print strAllCategories(j), iDurationPerCategory(j)
' Next
End Sub
Function WSHListSep()
Dim objWSHShell
Dim strReg
strReg = "HKCU\Control Panel\International\sList"
Set objWSHShell = CreateObject("WScript.Shell")
WSHListSep = objWSHShell.RegRead(strReg)
Set objWSHShell = Nothing
End Function
Reply With Quote
