Option Strict On Imports System.Globalization Imports System.IO Imports DevExpress.Data Imports DevExpress.Spreadsheet Imports DevExpress.XtraEditors Imports DevExpress.XtraGrid Imports DevExpress.XtraGrid.Views.Base Imports DevExpress.XtraGrid.Views.Grid Imports DevExpress.XtraScheduler Imports DevExpress.XtraScheduler.iCalendar Imports Ical.Net.DataTypes Imports Ical.Net.Serialization Imports Microsoft.Office.Interop Public Class frmMain ' Dinge, die in My.Settings gepackt werden können: Dim headDate As New TableHeader("Datum") Dim headTime As New TableHeader("Start") Dim headSubject As New TableHeader("Ausbildung") Dim headLocation As New TableHeader("Ort") Dim headCategory As New TableHeader("Art") Dim TableHeaders As New List(Of TableHeader) Dim ds As New List(Of EventEntry) Dim dv As DataView Dim dt1900 As New Date(1900, 1, 1) 'In diesem Form kann direkt die Excel-Datei von Jörg eingelesen werden 'Im Idealfall das dann direkt in den Scheduler gegeben werden, der dann eine ICS ausspuckt 'Dann muss nichtmal mehr die Excel-Datei bearbeitet werden Private Sub Form2_Load(sender As Object, e As EventArgs) Handles MyBase.Load prepare() With TableHeaders .Clear() .AddRange({headDate, headTime, headSubject, headLocation, headCategory}) End With End Sub Private Sub prepare() grd.DataSource = ds With grdv .PopulateColumns() .Columns(NameOf(EventEntry.StartDate)).DisplayFormat.FormatType = DevExpress.Utils.FormatType.DateTime .Columns(NameOf(EventEntry.StartDate)).DisplayFormat.FormatString = "ddd dd.MM.yy HH:mm" .Columns(NameOf(EventEntry.StartDate)).MinWidth = 100 .Columns(NameOf(EventEntry.StartDate)).ColumnEdit = ridtpStartEndDate .Columns(NameOf(EventEntry.EndDate)).DisplayFormat.FormatType = DevExpress.Utils.FormatType.DateTime .Columns(NameOf(EventEntry.EndDate)).DisplayFormat.FormatString = "ddd dd.MM.yy HH:mm" .Columns(NameOf(EventEntry.EndDate)).MinWidth = 100 .Columns(NameOf(EventEntry.EndDate)).ColumnEdit = ridtpStartEndDate .Columns(NameOf(EventEntry.StartDate)).Caption = "Start" .Columns(NameOf(EventEntry.EndDate)).Caption = "Ende" .Columns(NameOf(EventEntry.AllDay)).Caption = "Ganztag" .Columns(NameOf(EventEntry.Category)).Caption = "Art" .Columns(NameOf(EventEntry.Subject)).Caption = "Betreff" .Columns(NameOf(EventEntry.Location)).Caption = "Ort" .Columns(NameOf(EventEntry.Status)).Caption = "Hinweis" .Columns(NameOf(EventEntry.Status)).Visible = False .Columns(NameOf(EventEntry.Status)).OptionsColumn.AllowEdit = False .Columns(NameOf(EventEntry.Exclude)).Caption = "Ausschließen" .Columns(NameOf(EventEntry.IsInvalid)).Caption = "Ungültig" .Columns(NameOf(EventEntry.IsInvalid)).Visible = False .Columns(NameOf(EventEntry.IsInvalid)).OptionsColumn.AllowEdit = False .Columns(NameOf(EventEntry.RowIndex)).Visible = False .Columns(NameOf(EventEntry.RowIndex)).OptionsColumn.AllowEdit = False .Columns(NameOf(EventEntry.TimeZoneKey)).Visible = False .Columns(NameOf(EventEntry.TimeZoneKey)).OptionsColumn.AllowEdit = False End With grdv.FormatRules.Add(GridFunctions.CreateFormatRule(grdv, NameOf(EventEntry.Exclude), True, FormatCondition.Equal, True, backcolor:=Color.LightGray)) grdv.FormatRules.Add(GridFunctions.CreateFormatRule(grdv, NameOf(EventEntry.IsInvalid), True, FormatCondition.Equal, True, backcolor:=Color.MistyRose)) With schedStorage .Appointments.DataSource = ds With .Appointments.Mappings .AllDay = NameOf(EventEntry.AllDay) .Start = NameOf(EventEntry.StartDate) .End = NameOf(EventEntry.EndDate) .Subject = NameOf(EventEntry.Subject) .Location = NameOf(EventEntry.Location) .Label = NameOf(EventEntry.Category) '.TimeZoneId = NameOf(EventEntry.TimeZoneKey) End With .Appointments.CustomFieldMappings.Add(New AppointmentCustomFieldMapping(NameOf(EventEntry.IsInvalid), NameOf(EventEntry.IsInvalid))) .Appointments.CustomFieldMappings.Add(New AppointmentCustomFieldMapping(NameOf(EventEntry.Exclude), NameOf(EventEntry.Exclude))) .Labels.DataSource = General.Settings.Categories With schedStorage.Labels.Mappings .Color = NameOf(Category.Color) .Id = NameOf(Category.Key) .DisplayName = NameOf(Category.Text) .MenuCaption = NameOf(Category.Text) End With .Appointments.Filter = $"[{NameOf(EventEntry.IsInvalid)}] = FALSE AND [{NameOf(EventEntry.Exclude)}] = FALSE" End With sched.GoToToday() End Sub Private Sub ImportDatasourceFromFile(datei As String) schedStorage.Appointments.DataSource = Nothing grd.BeginUpdate() grd.DataSource = Nothing ds = GetEventsFromFile(datei) grd.DataSource = ds grd.EndUpdate() grdv.BestFitColumns() schedStorage.Appointments.DataSource = ds sched.RefreshData() End Sub Public Function GetEventsFromFile(datei As String) As List(Of EventEntry) Dim xlApp = New Excel.Application 'Im Fall von folgendem Fehler: 'The COM object of the type "Microsoft.Office.Interop.Excel.ApplicationClass" cannot be converted to the interface type "Microsoft.Office.Interop.Excel._Application". ' - Office 365 App reparieren (Schnellreparatur hat das letzte mal geholfen) ' - "32bit bevorzugen" deaktivieren in den Projekteinstellungen (ggf. bei 64bit Office?) ' - https://stackoverflow.com/questions/28066719/unable-to-cast-com-object-of-type-microsoft-office-interop-excel-applicationcla Dim xlMappe = xlApp.Workbooks.Open(datei) Dim xlBlatt As Excel.Worksheet 'xlApp = New Excel.Application() ' xlApp.Visible = False 'xlMappe = xlApp.Workbooks.Open(datei) xlBlatt = CType(xlMappe.Worksheets(1), Excel.Worksheet) Dim Events As New List(Of EventEntry) Dim ev As EventEntry 'Dim culture = CultureInfo.CreateSpecificCulture("de-DE") Dim headerfound As Boolean Dim HeaderRow As Integer 'Dim Headers As New List(Of TableHeader) 'Headers.AddRange() If xlBlatt.UsedRange.Rows.Count > 1 Then 'Kopfzeile suchen For i = 1 To xlBlatt.UsedRange.Rows.Count 'Prüfen, ob alle Header in der Row vorkommen For Each header As TableHeader In TableHeaders headerfound = False For j = 1 To xlBlatt.UsedRange.Columns.Count If CStr(CType(xlBlatt.Cells(i, j), Excel.Range).Text).Trim.ToLower = header.FieldName.Trim.ToLower Then header.ColumnIndex = j headerfound = True End If Next If headerfound = False Then HeaderRow = -1 Exit For Else HeaderRow = i End If Next If HeaderRow <> -1 Then Exit For Next If HeaderRow = -1 Then MessageBox.Show("Die Tabellenüberschriften wurden nicht gefunden. Bitte prüfen, ob die Zuordnungen vom Namen her noch stimmen", "Fehler", MessageBoxButtons.OK, MessageBoxIcon.Error) Return Nothing End If Dim zDatum, zStart As String Dim foreColor As Color ' Dim Status As New List(Of String) For i = HeaderRow + 1 To xlBlatt.UsedRange.Rows.Count ' Status.Clear() zDatum = CStr(CType(xlBlatt.Cells(i, headDate.ColumnIndex), Excel.Range).Text) zStart = CStr(CType(xlBlatt.Cells(i, headTime.ColumnIndex), Excel.Range).Text) ev = New EventEntry ev.RowIndex = i foreColor = System.Drawing.ColorTranslator.FromOle(CInt(CType(xlBlatt.Cells(i, headDate.ColumnIndex), Excel.Range).Font.Color)) If foreColor = Color.White Then ' Status.Add("Datum ist versteckt") ev.IsInvalid = True ElseIf zDatum.Trim.Length = 0 Then ' Status.Add("Kein Datum angegeben") ev.IsInvalid = True ElseIf zStart.Trim.Length > 0 AndAlso Date.TryParse($"{zDatum} {zStart}", ev.StartDate) Then ev.EndDate = ev.StartDate.AddHours(My.Settings.EndDateCalculationHoursToAdd) ElseIf Date.TryParse($"{zDatum}", ev.StartDate) Then 'Status.Add("Keine Zeit gefunden, gehe von Ganztag aus") ev.EndDate = ev.StartDate.Date.AddHours(24).AddMinutes(-1) ev.AllDay = True Else 'Status.Add("Datum konnte nicht ermittelt werden") ev.IsInvalid = True End If ev.Category = CStr(CType(xlBlatt.Cells(i, headCategory.ColumnIndex), Excel.Range).Text).Trim If ev.Category.Trim.Length > 0 AndAlso General.Settings.Categories.Exists(Function(c) c.Key = ev.Category) = False Then General.Settings.Categories.Add(New Category(ev.Category, ev.Category, Color.Red)) End If ev.Subject = CStr(CType(xlBlatt.Cells(i, headSubject.ColumnIndex), Excel.Range).Text).Trim ev.Location = CStr(CType(xlBlatt.Cells(i, headLocation.ColumnIndex), Excel.Range).Text).Trim ' ev.Status = String.Join(", ", Status.ToArray) If ev.Subject.Trim.Length > 0 Then Events.Add(ev) Next End If xlMappe.Close() xlApp.Quit() General.Settings.Save() RefreshEventExclusion(Events) CheckEventValidity(Events) Return Events End Function Private Sub RefreshEventExclusion(datasource As List(Of EventEntry)) For Each ev As EventEntry In datasource ev.Exclude = If(General.Settings.Categories.FirstOrDefault(Function(c) c.Key = ev.Category)?.Exclude, False) Next End Sub Private Sub CheckEventValidity(datasource As List(Of EventEntry)) For Each ev As EventEntry In datasource If ev.StartDate > dt1900 AndAlso ev.EndDate > dt1900 Then ev.IsInvalid = False End If Next End Sub Private Shared Sub Grdv_MouseWheel(sender As Object, e As MouseEventArgs) Handles grdv.MouseWheel TryCast(sender, GridView)?.CloseEditor() 'Klappt so auch mit BandedGridViews End Sub Private Sub btnOpenFile_ItemClick(sender As Object, e As DevExpress.XtraBars.ItemClickEventArgs) Handles btnOpenFile.ItemClick If OFD.ShowDialog = DialogResult.OK Then SFD.FileName = $"{Path.GetFileNameWithoutExtension(OFD.FileName)}.ics" SFD.InitialDirectory = Path.GetDirectoryName(OFD.FileName) ImportDatasourceFromFile(OFD.FileName) xlsSheet.LoadDocument(OFD.FileName) End If End Sub Private Sub btnCategories_ItemClick(sender As Object, e As DevExpress.XtraBars.ItemClickEventArgs) Handles btnCategories.ItemClick Dim frm As New frmSettings If frm.ShowDialog = DialogResult.OK Then RefreshEventExclusion(ds) CheckEventValidity(ds) grdv.RefreshData() schedStorage.RefreshData() End If End Sub Private Sub btnExport_ItemClick(sender As Object, e As DevExpress.XtraBars.ItemClickEventArgs) Handles btnExport.ItemClick GridFunctions.EndGridEdit(grdv) SFD.FileName = Path.GetFileNameWithoutExtension(OFD.FileName) & ".ics" If SFD.ShowDialog = DialogResult.OK Then 'schedStorage.TimeZoneId = General.Settings.DefaultTimezoneId Dim exporter As New iCalendarExporter(schedStorage) exporter.ProductIdentifier = "FW-EXPORTER" exporter.CustomPropertyIdentifier = "FWPROP" AddHandler exporter.AppointmentExporting, AddressOf Exporter_AppointmentExporting Dim failed As Boolean Try 'exporter.Export(SFD.FileName) IcalNetTest(SFD.FileName) Catch ex As Exception failed = True End Try If failed = False Then MessageBox.Show("Export abgeschlossen", "Kalenderexport", MessageBoxButtons.OK, MessageBoxIcon.Information) End If End Sub Private Sub IcalNetTest(OutputFile As String) Dim calendar As New Ical.Net.Calendar For Each evt As EventEntry In ds.Where(Function(e) e.IsInvalid = False AndAlso e.Exclude = False) calendar.Events.Add(New Ical.Net.CalendarComponents.CalendarEvent With { .Start = New CalDateTime(evt.StartDate), .[End] = New CalDateTime(evt.EndDate), .IsAllDay = evt.AllDay, .Location = evt.Location, .Summary = evt.Subject '.Categories = {evt.Category} Kategorien machen beim Import in Joomla JEvents probleme }) Next Dim serializer As New CalendarSerializer Dim utf8WithoutBom As New System.Text.UTF8Encoding(False) Using sw As New StreamWriter(OutputFile, False, utf8WithoutBom) 'NICHT einfach System.Text.Encoding.UTF8 nehmen, da dann als UTF8-BOM gespeichert wird und der Import z.B. Bei Samsung/Android-Handys nicht funktioniert sw.Write(serializer.SerializeToString(calendar)) End Using End Sub Private Sub Exporter_AppointmentExporting(sender As Object, e As AppointmentExportingEventArgs) 'e.Appointment.TimeZoneId = sched.OptionsBehavior.ClientTimeZoneId 'e.Appointment.TimeZoneId = General.Settings.DefaultTimezoneId If CType(e.Appointment.GetSourceObject(schedStorage), EventEntry).Exclude OrElse CType(e.Appointment.GetSourceObject(schedStorage), EventEntry).IsInvalid Then e.Cancel = True End If End Sub Private Sub grdv_CellValueChanged(sender As Object, e As CellValueChangedEventArgs) Handles grdv.CellValueChanged If e.Column.FieldName = NameOf(EventEntry.StartDate) OrElse e.Column.FieldName = NameOf(EventEntry.EndDate) Then Dim StartDate As Date = CDate(grdv.GetRowCellValue(e.RowHandle, NameOf(EventEntry.StartDate))) Dim EndDate As Date = CDate(grdv.GetRowCellValue(e.RowHandle, NameOf(EventEntry.EndDate))) If EndDate < StartDate Then grdv.SetRowCellValue(e.RowHandle, NameOf(EventEntry.EndDate), StartDate) End If ElseIf e.Column.FieldName = NameOf(EventEntry.AllDay) Then If CBool(e.Value) Then Dim EndDate As Date = CDate(grdv.GetRowCellValue(e.RowHandle, NameOf(EventEntry.EndDate))) grdv.SetRowCellValue(e.RowHandle, NameOf(EventEntry.EndDate), EndDate.Date.AddDays(1).AddSeconds(-1)) End If End If CheckEventValidity(ds) grdv.RefreshData() schedStorage.RefreshData() End Sub Private Sub grdv_SelectionChanged(sender As Object, e As SelectionChangedEventArgs) Handles grdv.SelectionChanged Dim workbook As IWorkbook = xlsSheet.Document Dim activeSheet As Worksheet = workbook.Worksheets.ActiveWorksheet xlsSheet.SelectedCell = activeSheet.Cells($"A{grdv.GetFocusedRowCellValue("RowIndex")}") activeSheet.ScrollTo(activeSheet.SelectedCell) End Sub Private Sub FluentDesignFormControl1_Click(sender As Object, e As EventArgs) Handles FluentDesignFormControl1.Click End Sub End Class