OK, here we go - below you'll find the entire sub:
Sub showCalItems(StartDate As Date, EndDate As Date)
On Error Resume Next
Dim myRestrictItems As Items, strTxt As String
Dim myCalItem As AppointmentItem, NodesCal As Nodes, nodX As Node
Dim NodXI As Node, itemStart As Date, itemEnd As Date, lDate As Date
Dim objCDO As Object, intIcon As Integer, intDayIcon As Integer
Dim strIncr As String, I As Integer
Dim intWeek As Integer, objRecurPattern As RecurrencePattern
Dim strTempArrayText As String
Const omHourAndMinute As String = "hh:nn"
Const omNullHour As String = "00:00"
Const omDayEnd As String = "ddddd 23:59"
Const omFullMoon As String = "fullMoon"
Const omNewMoon As String = "newMoon"
Const CdoPropSetID1 = "0220060000000000C000000000000046"
Const CdoAppt_Colors = "0x8214"
Set objCDO = CreateObject("MAPI.Session")
objCDO.Logon "", "", False, False
With
Application.GetNamespace("MAPI").GetDefaultFolder(olFolderCalendar).Items
.Sort "[Start]"
.IncludeRecurrences = True
Set myRestrictItems = .Restrict("[Start] >= '" & _
Format$(StartDate, "mmm-dd-yyyy 00:00") & "' And [Start] <='" &
_
Format$(EndDate, "mmm-dd-yyyy 23:59") & "' Or [End] >= '" & _
Format$(StartDate, "mmm-dd-yyyy 00:00") & "' And [End] <='" & _
Format$(EndDate, "mmm-dd-yyyy 23:59") & "' OR [Start]<'" & _
Format$(StartDate, "mmm-dd-yyyy 00:00") & "' AND [End]>'" & _
Format$(EndDate, "mmm-dd-yyyy 23:59") & "'")
End With
With frmViews
Set NodesCal = .treeCtl.Nodes
.treeCtl.ImageList = .ImgList
End With
With NodesCal
.Item(.Count).Selected = True
.Clear
End With
For lDate = StartDate To EndDate
If intWeek <> 0 Then Set nodX = NodesCal.Add(, , Format$(lDate,
"ddddd") & "a", vbNullString)
If intWeek = 0 Or intWeek <> Format(lDate, "WW", vbMonday) Then
intWeek = Format(lDate, "WW", vbMonday)
Set nodX = NodesCal.Add(, , Format$(lDate, "ddddd") & "w", _
String(22, 175) & " Week " & intWeek & " (" & 52 - intWeek
& ")")
nodX.Bold = True
End If
Select Case lDate
Case Date
Set nodX = NodesCal.Add(, , Format$(lDate, "ddddd"), "ToDay
(" & Format$(lDate, "dddd d.mmm") & ")", intDayIcon)
' NodX.BackColor = RGB(255, 200, 200)
Case Is < Date
Set nodX = NodesCal.Add(, , Format$(lDate, "ddddd"),
Format$(lDate, "dddd d. mmm"), intDayIcon)
nodX.ForeColor = RGB(150, 150, 150)
Case Is > Date
Set nodX = NodesCal.Add(, , Format$(lDate, "ddddd"),
Format$(lDate, "dddd d. mmm"), intDayIcon)
End Select
With nodX
.Bold = True
.Expanded = True
If Weekday(lDate, vbMonday) > 5 Then
.ForeColor = RGB(255, 0, 0)
End If
End With
Next
For Each myCalItem In myRestrictItems
With myCalItem
itemStart = .Start
itemEnd = .End
If itemEnd > itemStart And Format$(itemEnd, omHourAndMinute) =
omNullHour Then
itemEnd = Format(itemEnd - 1, omDayEnd)
End If
If itemStart < StartDate Then itemStart = StartDate
If itemEnd > EndDate Then itemEnd = EndDate
If .IsRecurring = True Then
intIcon = 9
ElseIf .ReminderSet = True Then
intIcon = 10
Else
intIcon = 2
End If
For lDate = DateValue(itemStart) To DateValue(itemEnd)
I = I + 1
If DateValue(itemStart) = lDate Then
strTxt = Format$(itemStart, "hh:nn ") & .Subject
Else
strTxt = .Subject
End If
If Len(.Location) > 0 Then strTxt = strTxt & " (" &
.Location & ")"
Select Case lDate
Case Date
Set NodXI = NodesCal.Add(Format$(lDate, "ddddd"),
tvwChild, _
.EntryID & Chr(I), strTxt, intIcon)
Case Is < Date
Set NodXI = NodesCal.Add(Format$(lDate, "ddddd"),
tvwChild, _
.EntryID & Chr(I), strTxt, intIcon)
NodXI.ForeColor = RGB(150, 150, 150)
Case Is > Date
Set NodXI = NodesCal.Add(Format$(lDate, "ddddd"),
tvwChild, _
.EntryID & Chr(I), strTxt, intIcon)
End Select
If .IsRecurring = True Then
Set objRecurPattern = .GetRecurrencePattern
If objRecurPattern.RecurrenceType = olRecursYearly Then
_
NodXI.Text = "(" & DateDiff("yyyy",
objRecurPattern.PatternStartDate, lDate) & " år) " & .Subject
End If
With objCDO.GetMessage(.EntryID, _
.Parent.StoreID).Fields.Item(CdoAppt_Colors,
CdoPropSetID1)
Select Case .Value
Case 0
Case 1
NodXI.BackColor = RGB(255, 180, 180)
Case 2
NodXI.BackColor = RGB(145, 145, 255)
Case 3
NodXI.BackColor = RGB(170, 255, 170)
Case 4
NodXI.BackColor = RGB(192, 192, 192)
Case 5
NodXI.BackColor = RGB(255, 182, 108)
Case 6
NodXI.BackColor = RGB(128, 255, 255)
Case 7
NodXI.BackColor = RGB(177, 177, 101)
Case 8
NodXI.BackColor = RGB(255, 220, 220)
Case 9
NodXI.BackColor = RGB(0, 166, 166)
Case 10
NodXI.BackColor = RGB(255, 255, 155)
End Select
End With
Next
End With
Next
NodesCal(1).Selected = True
NodesCal(1).Selected = False
Set myRestrictItems = Nothing
Set nodX = Nothing
Set NodXI = Nothing
Set NodesCal = Nothing
Set objRecurPattern = Nothing
Set objCDO = Nothing
End Sub
"Sue Mosher [MVP]" <
[email protected]> skrev i melding
How did you instantiate myRestrictItems? With or without Sort and
IncludeRecurrences? It's awfully hard to try to duplicate an issue without
even knowing whether you're getting master AppointmentItem objects or
individual recurrences.
--
Sue Mosher, Outlook MVP
Outlook and Exchange solutions at
http://www.slipstick.com
Author of
Microsoft Outlook Programming: Jumpstart
for Administrators, Power Users, and Developers
Hans-Christian Francke said:
myCalItem refer to a specific AppointmentItem within a For Next loop.
For Each myCalItem In myRestrictItems
'then the code in here
Next
