P
Pjdav
Outlook 2003/Exchange Server 2003/Outlook Calendars/ Window XP
Not sure if this is an exchange server config issue, a known bug, a required
hotfix, or if this code of mind is wrong. Searched for anything resembling
this, no joy.
VBA inside of MS Project 2003 using the Outlook model. When the calendar is
the "session" (getDefaultFolder) calendar (not provided by exchange), then
NO problem.
If the calendar is a public calendar, or a shared (GetSharedDefaultFolder)
calendar then any attempt to get past the items after 255, causes the code to
drop out of debug and return to an error handler.
Tried caching the entire array, then tried getfirst/getnext, then tried
Restriction, then Find, and lastly Find inside a restriction build from the
parent calendar itself.
Count always returns correct. But with or without restrictions, no more than
255 items are ever returned in the collection, if the manager of the
collection is Exchange based.
-------------
Set PubCalendarList(CCtr) = GetPublicFolder(PubFolderPath(CCtr))
Set ExistAppts = PubCalendarList(CCtr).Items
ExistApptCount = ExistAppts.Count
ReDim ExistApptArray(ExistApptCount + 1)
Set objFolder = PubCalendarList(CCtr)
GetAllAppointments objFolder, ExistApptArray
Sub GetAllAppointments(ByRef InCal As Outlook.MAPIFolder, ByRef ItemsArray()
As Outlook.AppointmentItem)
Dim CurrentWeek As Date
Dim NumberOfWeeks As Long, ResSpanItemsCount As Long
Dim Index As Long, Counter As Long, OverallPosition As Long
Dim myStart As String, myEnd As String, StrRestriction As String
Dim ResSpanItems As Outlook.Items
Dim ExistAppt As Object
On Error GoTo ErrorHandler
CurrentWeek = WorldBegins
NumberOfWeeks = WeeksInWorld
OverallPosition = 0
For Index = 1 To (NumberOfWeeks)
myStart = Format(CurrentWeek, "mm/dd/yyyy hh:mm AMPM")
myEnd = Format(DateAdd("d", 7, myStart), "mm/dd/yyyy hh:mm AMPM")
StrRestriction = "[Start] >= '" & myStart & "' AND [Start] < '" &
myEnd & "'"
InCal.Items.Sort "[Start]"
Set ResSpanItems = InCal.Items.Restrict(StrRestriction)
ResSpanItems.Sort "[Start]"
ResSpanItemsCount = ResSpanItems.Count
For Counter = 1 To ResSpanItemsCount
OverallPosition = OverallPosition + 1
If (Counter = 1) Then
Set ExistAppt = ResSpanItems.Find(StrRestriction)
Else
Set ExistAppt = ResSpanItems.FindNext
End If
If ExistAppt Is Nothing Then
MsgBox "Item is Nothing"
Else
Set ItemsArray(OverallPosition) = ExistAppt
End If
Next Counter
Set ResSpanItems = Nothing
CurrentWeek = CurrentWeek + 7
Next Index
Exit Sub
ErrorHandler:
MsgBox "OverRun"
End Sub
-------------
" Cannot read back more than 256 appointments "
" The First 250 read back fine "
" The next 5 read back empty "
" Any attempt to read back items after 255 crash the operation "
The goal is to cache the entire appointment set to compare to another set.
Any guidance would be greatly appreciated
Not sure if this is an exchange server config issue, a known bug, a required
hotfix, or if this code of mind is wrong. Searched for anything resembling
this, no joy.
VBA inside of MS Project 2003 using the Outlook model. When the calendar is
the "session" (getDefaultFolder) calendar (not provided by exchange), then
NO problem.
If the calendar is a public calendar, or a shared (GetSharedDefaultFolder)
calendar then any attempt to get past the items after 255, causes the code to
drop out of debug and return to an error handler.
Tried caching the entire array, then tried getfirst/getnext, then tried
Restriction, then Find, and lastly Find inside a restriction build from the
parent calendar itself.
Count always returns correct. But with or without restrictions, no more than
255 items are ever returned in the collection, if the manager of the
collection is Exchange based.
-------------
Set PubCalendarList(CCtr) = GetPublicFolder(PubFolderPath(CCtr))
Set ExistAppts = PubCalendarList(CCtr).Items
ExistApptCount = ExistAppts.Count
ReDim ExistApptArray(ExistApptCount + 1)
Set objFolder = PubCalendarList(CCtr)
GetAllAppointments objFolder, ExistApptArray
Sub GetAllAppointments(ByRef InCal As Outlook.MAPIFolder, ByRef ItemsArray()
As Outlook.AppointmentItem)
Dim CurrentWeek As Date
Dim NumberOfWeeks As Long, ResSpanItemsCount As Long
Dim Index As Long, Counter As Long, OverallPosition As Long
Dim myStart As String, myEnd As String, StrRestriction As String
Dim ResSpanItems As Outlook.Items
Dim ExistAppt As Object
On Error GoTo ErrorHandler
CurrentWeek = WorldBegins
NumberOfWeeks = WeeksInWorld
OverallPosition = 0
For Index = 1 To (NumberOfWeeks)
myStart = Format(CurrentWeek, "mm/dd/yyyy hh:mm AMPM")
myEnd = Format(DateAdd("d", 7, myStart), "mm/dd/yyyy hh:mm AMPM")
StrRestriction = "[Start] >= '" & myStart & "' AND [Start] < '" &
myEnd & "'"
InCal.Items.Sort "[Start]"
Set ResSpanItems = InCal.Items.Restrict(StrRestriction)
ResSpanItems.Sort "[Start]"
ResSpanItemsCount = ResSpanItems.Count
For Counter = 1 To ResSpanItemsCount
OverallPosition = OverallPosition + 1
If (Counter = 1) Then
Set ExistAppt = ResSpanItems.Find(StrRestriction)
Else
Set ExistAppt = ResSpanItems.FindNext
End If
If ExistAppt Is Nothing Then
MsgBox "Item is Nothing"
Else
Set ItemsArray(OverallPosition) = ExistAppt
End If
Next Counter
Set ResSpanItems = Nothing
CurrentWeek = CurrentWeek + 7
Next Index
Exit Sub
ErrorHandler:
MsgBox "OverRun"
End Sub
-------------
" Cannot read back more than 256 appointments "
" The First 250 read back fine "
" The next 5 read back empty "
" Any attempt to read back items after 255 crash the operation "
The goal is to cache the entire appointment set to compare to another set.
Any guidance would be greatly appreciated