OUTLOOK ICAL EXPORTER

Imports Microsoft.Office.Interop.Outlook
Imports System.IO
Imports System.Text
Imports System.Array
Imports CalExporter.FTPclient

Module CalItem
    Sub Main()
        Dim objOL As Object
        Dim s As New OutlookAddIn.GetApplication
        objOL = s.GetApplicationObject()
        Dim MyNameSpace As Microsoft.Office.Interop.Outlook.NameSpace
        MyNameSpace = objOL.GetNameSpace("MAPI")
        Dim cats As Microsoft.Office.Interop.Outlook.Categories
        cats = MyNameSpace.Categories
        If (cats.Count > 1) Then
            For Each cat As Microsoft.Office.Interop.Outlook.Category In cats
                CatOutPut(MyNameSpace, cat)
            Next
        End If
    End Sub
    Sub CatOutPut(ByRef MyNameSpace As Microsoft.Office.Interop.Outlook.NameSpace, ByVal category As Microsoft.Office.Interop.Outlook.Category)
        Dim out As String
        out = "BEGIN:VCALENDAR" & Chr(10)
        out += "PRODID:-//hacksw/handcal//NONSGML v1.0//EN" & Chr(10)
        out += "VERSION:2.0" & Chr(10)
        Dim myFolder As Object
        myFolder = MyNameSpace.GetDefaultFolder(Microsoft.Office.Interop.Outlook.OlDefaultFolders.olFolderCalendar)
        Dim myTaskFolder As Object
        myTaskFolder = MyNameSpace.GetDefaultFolder(Microsoft.Office.Interop.Outlook.OlDefaultFolders.olFolderTasks)
        Dim myTaskItems As Object
        myTaskItems = myTaskFolder.Items
        Dim myItems As Object
        myItems = myFolder.Items
        Dim e As Microsoft.Office.Interop.Outlook.AppointmentItem
        For Each e In myItems
            If e.Categories <> String.Empty Then
                If e.Categories.Contains(category.Name) Then
                    out += "BEGIN:VEVENT" & Chr(10)
                    out += "UID:" & e.EntryID & Chr(10)
                    If e.Categories <> "" Then
                        out += "CATEGORIES:" & NoSpac(e.Categories.Replace(";"c, ","c)) & Chr(10)
                    End If
                    out += "DTSTAMP:" & ToDate69(e.CreationTime.ToUniversalTime) & Chr(10)
                    out += "DTSTART:" & ToDate69(e.Start.ToUniversalTime) & Chr(10)
                    out += "DTEND:" & ToDate69(e.End.ToUniversalTime) & Chr(10)
                    out += "SUMMARY:" & RFC5545_TEXT(e.Subject) & Chr(10)
                    'out += "DESCRIPTION:" & RFC5545_TEXT(e.Body) & Chr(10)
                    out += "LOCATION:" & RFC5545_TEXT(e.Location) & Chr(10)
                    If e.RecurrenceState = OlRecurrenceState.olApptMaster Then
                        out += ("RECURRENCE-ID:") & ToDate69(e.StartUTC) & Chr(10)
                        out += "RRULE:"
                        Dim f As Microsoft.Office.Interop.Outlook.RecurrencePattern
                        f = e.GetRecurrencePattern()
                        'Console.WriteLine("VALUES:monthofyear" & f.MonthOfYear & "dayofmonth:" & f.DayOfMonth & "daysofweekmask:" & f.DayOfWeekMask & "interval:" & f.Interval & "instance:" & f.Instance & "type:" & f.RecurrenceType)
                        Select Case f.RecurrenceType
                            Case OlRecurrenceType.olRecursYearNth
                                out += "FREQ=YEARLY;"
                                out += "INTERVAL=" & f.Interval & ";"
                                out += "BYMONTH=" & f.MonthOfYear & ";"
                                out += "BYDAY=" & GetDays(f.DayOfWeekMask) & ";"
                                out += "BYMONTHDAY=" & GetMonthDays(f.Instance) & ";"
                            Case OlRecurrenceType.olRecursMonthNth
                                out += "FREQ=MONTHLY;"
                                out += "INTERVAL=" & f.Interval & ";"
                                out += "BYDAY=" & GetDays(f.DayOfWeekMask) & ";"
                                out += "BYMONTHDAY=" & GetMonthDays(f.Instance) & ";"
                            Case OlRecurrenceType.olRecursYearly
                                out += "FREQ=YEARLY;"
                                out += "INTERVAL=" & f.Interval & ";"
                                out += "BYMONTH=" & f.MonthOfYear & ";"
                                out += "BYMONTHDAY=" & f.DayOfMonth & ";"
                            Case OlRecurrenceType.olRecursMonthly
                                out += "FREQ=MONTHLY;"
                                out += "INTERVAL=" & f.Interval & ";"
                                out += "BYMONTHDAY=" & f.DayOfMonth & ";"
                            Case OlRecurrenceType.olRecursWeekly
                                out += "FREQ=WEEKLY;"
                                out += "INTERVAL=" & f.Interval & ";"
                                out += "BYDAY=" & GetDays(f.DayOfWeekMask) & ";"
                            Case OlRecurrenceType.olRecursDaily
                                out += "FREQ=DAILY;"
                                out += "INTERVAL=" & f.Interval & ";"
                        End Select
                        If f.NoEndDate Then
                            out += "UNTIL=45001231235900Z"
                        Else
                            Dim endDate As Date
                            endDate = f.PatternEndDate.ToUniversalTime
                            out += "UNTIL=" & ToDate69(endDate.ToUniversalTime)
                        End If
                        out += Chr(10)
                        If f.Exceptions.Count > 1 Then
                            out += "EXDATE:"
                            Dim isLast = False
                            Dim enumerator As IEnumerator
                            enumerator = f.Exceptions.GetEnumerator()
                            enumerator.MoveNext()
                            While Not isLast
                                out += ToDate69(enumerator.Current.OriginalDate.ToUniversalTime)
                                If Not enumerator.MoveNext Then
                                    isLast = True
                                Else
                                    out += ","
                                End If
                            End While
                            out += Chr(10)
                        End If
                    ElseIf e.RecurrenceState = OlRecurrenceState.olApptOccurrence Then
                        'treat exception cases
                        out += ("RECURRENCE-ID:") & ToDate69(e.StartUTC) & Chr(10)
                        'Console.WriteLine("OCCURRENCE")
                    End If

                    out += "END:VEVENT" & Chr(10)
                End If
            End If
        Next
        Dim task As Microsoft.Office.Interop.Outlook.TaskItem
        For Each task In myTaskItems
            If task.Categories <> String.Empty Then
                If task.Categories.Contains(category.Name) Then
                    out += "BEGIN:VTODO" & Chr(10)
                    out += "UID:" & task.EntryID & Chr(10)
                    out += "DTSTAMP:" & ToDate69(task.CreationTime) & Chr(10)
                    If task.Status = OlTaskStatus.olTaskComplete Then
                        out += "COMPLETED:" & ToDate69(task.DateCompleted.ToUniversalTime) & Chr(10)
                    End If
                    If Date.Compare(task.StartDate, New Date(4499, 12, 31)) < 0 Then
                        out += "DTSTART:" & ToDate69(task.StartDate.ToUniversalTime)
                    End If
                    If task.Status = OlTaskStatus.olTaskInProgress Then
                        out += "STATUS:IN-PROGRESS" & Chr(10)
                    ElseIf task.Status = OlTaskStatus.olTaskWaiting Then
                        out += "STATUS:NEEDS-ACTION" & Chr(10)
                    End If
                    out += "SUMMARY:" & task.Subject & Chr(10)
                    If Date.Compare(task.DueDate, New Date(4499, 12, 31)) < 0 Then
                        out += "DUE:" & ToDate69(task.DueDate.ToUniversalTime) & Chr(10)
                    End If
                    out += "CATEGORIES:" & NoSpac(task.Categories.Replace(";"c, ","c)) & Chr(10)
                    out += "END:VTODO" & Chr(10)
                End If
                End If
        Next
        out += "END:VCALENDAR" & Chr(10)
        File.WriteAllText("C:\Program1\" & category.Name & ".ics", out, System.Text.Encoding.UTF8)
        Dim ftp As FTPclient
        Dim localFile As String = "C:\Program1\" & category.Name & ".ics"
        Dim remoteFile As String = "www/cal/calendars/" & category.Name & ".ics"
        Const host As String = "ftp://FTPSITE.COM/"
        Const username As String = "USERNAME"
        Const password As String = "<PASSWORD>"
        ftp = New FTPclient(host, username, password)
        ftp.Upload(localFile, remoteFile)
    End Sub
    Public Function ToDig(ByVal value As Integer) As String
        If value <= 9 Then
            Dim a As String
            a = "0" & value
            ToDig = a
        Else
            ToDig = value.ToString
        End If
        Exit Function
    End Function
    Public Function NoSpac(ByVal value As String) As String
        Dim str As String
        str = ""
        For Each ch As Char In value.ToCharArray
            If ch <> " "c Then
                str += ch
            End If
        Next
        NoSpac = str
        Exit Function
    End Function
    Public Function ToDate69(ByVal d As Date) As String
        Dim str As String
        str = d.Year & ToDig(d.Month) & ToDig(d.Day) & ToDig(d.Hour) & ToDig(d.Minute) & "00Z"
        ToDate69 = str
        Exit Function
    End Function
    Public Function GetDays(ByVal d As Integer) As String
        Dim out As String
        out = ""
        Dim once As Boolean
        once = False
        If (d And OlDaysOfWeek.olSunday) Then
            out += "SU"
            once = True
        End If
        If (d And OlDaysOfWeek.olMonday) Then
            If (once) Then
                out += ","
            End If
            out += "MO"
            once = True
        End If
        If (d And OlDaysOfWeek.olTuesday) Then
            If (once) Then
                out += ","
            End If
            out += "TU"
            once = True
        End If
        If (d And OlDaysOfWeek.olWednesday) Then
            If (once) Then
                out += ","
            End If
            out += "WE"
            once = True
        End If
        If (d And OlDaysOfWeek.olThursday) Then
            If (once) Then
                out += ","
            End If
            out += "TH"
            once = True
        End If
        If (d And OlDaysOfWeek.olFriday) Then
            If (once) Then
                out += ","
            End If
            out += "FR"
            once = True
        End If
        If (d And OlDaysOfWeek.olSaturday) Then
            If (once) Then
                out += ","
            End If
            out += "SA"
        End If
        GetDays = out
        Exit Function
    End Function
    Public Function GetMonthDays(ByVal xieme As Integer) As String
        Select Case xieme
            Case 1
                GetMonthDays = "1,2,3,4,5,6,7"
            Case 2
                GetMonthDays = "8,9,10,11,12,13,14"
            Case 3
                GetMonthDays = "15,16,17,18,19,20,21"
            Case 4
                GetMonthDays = "22,23,24,25,26,27,28"
            Case 5
                GetMonthDays = "29,30,31"
            Case Else
                GetMonthDays = "0"
        End Select
        Exit Function
    End Function
    Public Function RFC5545_TEXT(ByVal s As String) As String
        If s <> String.Empty Then
            s = s.Replace("\", "\\")
            s = s.Replace(";", "\;")
            s = s.Replace(",", "\,")
            s = s.Replace(vbNewLine, "\n")
        End If
        RFC5545_TEXT = s
        Exit Function
    End Function
End Module