Read Outlook Calendar with Outlook Redemption.dll 

Module Module1

    Sub Main()

        Dim dictColors As New Dictionary(Of String, Integer)

        If True Then

            Dim RDOSession As New Redemption.RDOSession

            'Dim Session As Redemption.RDOSession = CreateObject("Redemption.RDOSession")

            RDOSession.Logon("Outlook")

            'Set RDOFolder = RDOSession.GetDefaultFolder(olFolderInbox)

            Dim RDOFolder As Redemption.RDOFolder

            'RDOFolder = RDOSession.GetFolderFromPath("\\RichLemmermann@crouse.org\MedSurg Infusions\Calendar")

            RDOFolder = RDOSession.GetFolderFromPath("\\MedSurg Infusions\Calendar")

            'RDOFolder = RDOSession.GetDefaultFolder(rdoDefaultFolders.olFolderInbox)

            'RDOSession.Stores.FindExchangePublicFoldersStore()

            REM crousescripts_AoC::crousescripts_AoC5551212

            Dim RDOItems As Redemption.RDOItems

            RDOItems = RDOFolder.Items

            REM RDOItems.Sort "ReceivedTime", True

            Console.WriteLine("Count: " & RDOItems.Count)

            'console.writeline funWriteText(sFileName,"Count: " & RDOItems.Count)

            If RDOItems.Count > 0 Then

                For Each oItem In RDOItems

                    'Console.WriteLine("> " & oItem)

                    Dim oMail As Redemption.RDOAppointmentItem 'rdomail

                    oMail = RDOSession.GetMessageFromID(oItem.EntryID)

                    'Console.WriteLine(oMail.Start.ToShortDateString & " = " & DateAdd(DateInterval.Day, 0, Now).ToShortDateString & " and  " & oMail.Start.ToShortDateString & " >= " & DateAdd(DateInterval.Day, 0, Now).ToShortDateString & " And " & DateAdd(DateInterval.Day, 0, Now).ToShortDateString & " <= " & oMail.End.ToShortDateString)

                    'Console.WriteLine(oMail.Start.ToShortDateString & " >= " & DateAdd(DateInterval.Day, 0, Now).ToShortDateString & " And " & DateAdd(DateInterval.Day, 0, Now).ToShortDateString & " <= " & oMail.End.ToShortDateString)

                    'Console.WriteLine(oMail.Start.ToShortDateString & " = " & Now.ToShortDateString)

                    Dim bProcess As Boolean = False

                    If oMail.IsRecurring Then

                        If oMail.Start.ToShortDateString <= DateAdd(DateInterval.Day, 0, Now).ToShortDateString And DateAdd(DateInterval.Day, 0, Now).ToShortDateString <= DateAdd(DateInterval.Minute, oMail.Duration, oMail.Start).ToShortDateString Then

                            'If oMail.Start.ToShortDateString <= DateAdd(DateInterval.Day, 0, Now).ToShortDateString And DateAdd(DateInterval.Day, 0, Now).ToShortDateString >= DateAdd(DateInterval.Minute, oMail.Duration, oMail.Start).ToShortDateString Then

                            'start  today  duration  end

                            Console.WriteLine("Recurring")

                            bProcess = True

                        End If

                        ' Console.WriteLine(vbTab & oMail.Subject.ToString & "," & oMail.Start.ToString & "," & oMail.End.ToString)

                    ElseIf oMail.Start.ToShortDateString = DateAdd(DateInterval.Day, 0, Now).ToShortDateString Or oMail.End.ToShortDateString = DateAdd(DateInterval.Day, 0, Now).ToShortDateString Then

                        bProcess = True

                        Console.WriteLine("Day of Day=Day")

                    ElseIf oMail.Start.ToShortDateString <= DateAdd(DateInterval.Day, 0, Now).ToShortDateString And DateAdd(DateInterval.Day, 0, Now).ToShortDateString <= oMail.End.ToShortDateString Then

                        Console.WriteLine("Day in between. Not recurring")

                        bProcess = True

                    End If

                    If bProcess Then

                        Dim sColor As String = ""

                        sColor = IIf(oMail.Categories Is Nothing, "NOTHING", "" & oMail.Categories)

                        Console.WriteLine(vbTab & oMail.Subject.ToString & "," & oMail.Start.ToString & "," & oMail.End.ToString)

                        'Console.WriteLine(oMail.Start.ToShortDateString & " = " & DateAdd(DateInterval.Day, 0, Now).ToShortDateString & " and  " & oMail.Start.ToShortDateString & " >= " & DateAdd(DateInterval.Day, 0, Now).ToShortDateString & " And " & DateAdd(DateInterval.Day, 0, Now).ToShortDateString & " <= " & oMail.End.ToShortDateString)

                        'Debug.Print("here: " & oMail.Subject.ToString & " " & oMail.CreationTime.ToString & " " & oMail.SenderEmailAddress.ToString & " " & sColor)

                        'Console.WriteLine("" & oMail.Subject.ToString & " " & oMail.CreationTime.ToString & " " & IIf(oMail.Categories Is Nothing, "NOTHING", "COLOR: " & oMail.Categories))

                        'If dictColors(IIf(oMail.Categories Is Nothing, "NOTHING", "COLOR: " & oMail.Categories)) Then

                        If dictColors.ContainsKey(LCase(sColor)) Then

                            Dim dFind As KeyValuePair(Of String, Integer) = dictColors.First(Function(value As KeyValuePair(Of String, Integer)) value.Key.Equals(LCase(sColor)))

                            dictColors(dFind.Key) += 1

                        Else

                            dictColors.Add(LCase(sColor), 1)

                        End If

                    End If

                    'Codes.First(Function(S) S.Key.Equals(Key))

                    'If

                    'If oMail.Attachments.Count = 0 Then

                    '    If (funInsertValue(oMail.Subject, oMail.ReceivedTime, oMail.Size, "email", oMail.SenderName, System.Text.Encoding.ASCII.GetBytes("No Attachments"), Encoding.ASCII.GetBytes(oMail.Body), Encoding.ASCII.GetBytes(oMail.HTMLBody))) Then

                    '        oMail.Delete()

                    '    End If ' funGetAttachStream

                    'End If

                    'For Each att In oMail.Attachments

                    '    Console.WriteLine("   Attach: " & att.filename)

                    '    'oMail.SaveAs("c:\temp\hi\" & att.filename)

                    '    Dim sBody As Byte()

                    '    Try

                    '        sBody = Encoding.ASCII.GetBytes(oMail.Body)

                    '    Catch ex As Exception

                    '        sBody = Encoding.ASCII.GetBytes(("Blank"))

                    '    End Try

                    '    Dim sBodyHTML As Byte()

                    '    Try

                    '        sBodyHTML = Encoding.ASCII.GetBytes(oMail.HTMLBody)

                    '    Catch ex As Exception

                    '        sBodyHTML = Encoding.ASCII.GetBytes("Blank")

                    '    End Try

                    '    If (funInsertValue(oMail.Subject, oMail.ReceivedTime, oMail.Size, att.filename, oMail.SenderName, (att.asArray), sBody, sBodyHTML)) Then

                    '        oMail.Delete()

                    '    End If ' funGetAttachStream

                    '    ' System.Convert.ToBase64String(System.Text.Encoding.Unicode.GetBytes(att.AsText))

                    'Next

                Next

            End If

            If Err.Number <> 0 Then

                'call subSendEMail(cSourceEmail,"richlemmermann@crouse.org","richlemmermann@crouse.org","Error in code for eRX" & vbCrlf & sBody & err.description)

            End If

            RDOSession.Logoff()

        Else

            'For x As Integer = 1 To 15

            '    Console.WriteLine(funGetContents(x))

            'Next

        End If

        ' Console.WriteLine(vbCrLf & "Press ENTER")

        ' Console.ReadLine()

        Console.WriteLine("dictColors key count: " & dictColors.Keys.Count)

        For Each kP As KeyValuePair(Of String, Integer) In dictColors

            Console.WriteLine(Replace(Replace(kP.Key, ",", "|"), " category", "") & "," & kP.Value)

        Next

    End Sub

End Module