Outlook ical exporter
Description
L'API .NET d'Outlook fournit une méthode standard "ForwardAsVCal" qui transmet un mail avec en pièce jointe un fichier ics qui par contre ne contient pas l'élément CATEGORIES de la spécication ical v2.0 des VEVENT
Cette Source fait un upload du calendrier et des tâches outlook de l'odrinateur local vers le serveur FTP de votre choix. Il y a un fichier *.ics par categorie Outlook ou * est le nom de la categorie.
<i>The .NET Outlook API does provide a standard method ForwardAsVcal which does send a mail with attached ics file that perhaps does not contains CATEGORIES component in VEVENT ITEMS
This source does an upload of the main local computer outlook calendar as well as todo tasks. There is one *.ics upload per Outlook Category where * is the category name.
</i>
La méthode pour obtenir un "Handle" sur Outlook peut varier selon que vous utilisiez exchange ou non, je conseille cet excellent site : outlookcode.com
Aussi ai-je publié une page de démonstration avec ce programme : http://www.xsimo.com/cal.htm
Cette Source fait un upload du calendrier et des tâches outlook de l'odrinateur local vers le serveur FTP de votre choix. Il y a un fichier *.ics par categorie Outlook ou * est le nom de la categorie.
<i>The .NET Outlook API does provide a standard method ForwardAsVcal which does send a mail with attached ics file that perhaps does not contains CATEGORIES component in VEVENT ITEMS
This source does an upload of the main local computer outlook calendar as well as todo tasks. There is one *.ics upload per Outlook Category where * is the category name.
</i>
Source / Exemple :
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
Conclusion :
La méthode pour obtenir un "Handle" sur Outlook peut varier selon que vous utilisiez exchange ou non, je conseille cet excellent site : outlookcode.com
Aussi ai-je publié une page de démonstration avec ce programme : http://www.xsimo.com/cal.htm
Codes Sources
A voir également
- Outlook ical exporter
- Exporter discussion en arabe - Forum Delphi / Pascal
- Activer macro outlook - Forum Visual Basic
- Les macros sur Outlook ne fonctionnent plus et ne sont plus accessibles ! - Forum VBA Office (Excel, Word ...)
- Comment activer les macro dans outlook - Forum Visual Basic
- Sw exporter - Forum C# / .NET