Option Strict On 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 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 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) 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 fill(datei As String) schedStorage.Appointments.DataSource = Nothing grd.BeginUpdate() grd.DataSource = Nothing ds = Readout(datei) grd.DataSource = ds grd.EndUpdate() grdv.BestFitColumns() schedStorage.Appointments.DataSource = ds sched.RefreshData() End Sub Public Function Readout(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 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 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) fill(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 frmCategoryEdit 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 SFD.FileName = Path.GetFileNameWithoutExtension(OFD.FileName) & ".ics" If SFD.ShowDialog = DialogResult.OK Then Dim exporter As New iCalendarExporter(schedStorage) AddHandler exporter.AppointmentExporting, AddressOf Exporter_AppointmentExporting exporter.Export(SFD.FileName) End If End Sub Private Sub Exporter_AppointmentExporting(sender As Object, e As AppointmentExportingEventArgs) 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 End Class