![]() |
ICS import zu exel - Druckversion +- Office-Fragen.de (https://office-fragen.de) +-- Forum: Microsoft Office (https://office-fragen.de/forum-1.html) +--- Forum: Excel (https://office-fragen.de/forum-2.html) +--- Thema: ICS import zu exel (/thread-29143.html) |
ICS import zu exel - Carsten-Wählisch - 15.05.2024 Hallo Ich benötige Hilfe Ich habe einen VBA Code für ICS import zu exel. Meine ICS Datei ist aus einem Google Kalender. Mein Problem ist die Zeit. Sie wird mir nur als 0:00:00 Angezeigt. Was ist mein Fehler. Sub ICS_Import() ' modifiziert nach: https://www.experts-exchange.com/questions/26193790/Importing-Calendar-files-into-Excel-ics-xls.html ' This version require a reference to a "Microsoft ActiveX Data Objects" Dim filename As String filename = Application.GetOpenFilename("Calendar Files (*.ics),*.ics") If filename = "False" Then Exit Sub Dim objStream, strData Dim r As Long, c As Long, lineCount As Long, line As String, dtStr As String, aStr As String, mlValue As String, dtArr() As String Dim colNames As Variant colNames = Array("DTSTART", "TIMESTART", "DTEND", "TIMEEND", "DTSTAMP", "UID", "CREATED", "DESCRIPTION", "RRULE", "LAST-MODIFIED", "LOCATION", "SEQUENCE", "STATUS", "SUMMARY", "TRANSP") Dim EventStart As Boolean Set objStream = CreateObject("ADODB.Stream") 'objStream.Charset = "utf-8" 'objStream.Charset = "windows-1252" '"_autodetect_all" ? objStream.Charset = "_autodetect_all" objStream.Open objStream.Type = adTypeText objStream.LoadFromFile (filename) c = 0 For c = 0 To 14 Cells(1, c + 1).Value = colNames© Next c r = 2 EventStart = False lineCount = 0 line = objStream.ReadText(adReadLine) Do Until objStream.EOS If Left(line, 1) <> Chr(9) Then 'Corrected a cut/paste bug " " == chr(9) aStr = Split(line, ":")(0) End If If Left(line, 12) = "BEGIN:VEVENT" Then 'Die ersten Zeilen ("Header") bis zum ersten Ereignis werden ignoriert EventStart = True End If If EventStart = True Then dtStr = Replace(line, aStr & ":", "") Select Case True Case Left(line, 7) = "DTSTART" Cells(r, 1) = Format(ParseDateZ(dtStr), "yyyy-mm-dd hh:mm ![]() 'Spalte "TIMESTART" Cells(r, 2) = Cells(r, 1) Case Left(line, 5) = "DTEND" Cells(r, 3) = Format(ParseDateZ(dtStr), "yyyy-mm-dd hh:mm ![]() 'Spalte "TIMEEND" Cells(r, 4) = Cells(r, 3) Case Left(line, 7) = "DTSTAMP" Cells(r, 5) = Format(ParseDateZ(dtStr), "yyyy-mm-dd hh:mm ![]() Case Left(line, 3) = "UID" Cells(r, 6) = dtStr Case Left(line, 7) = "CREATED" Cells(r, 7) = Format(ParseDateZ(dtStr), "yyyy-mm-dd hh:mm ![]() Case Left(line, 11) = "DESCRIPTION" Cells(r, 8) = dtStr Case Left(line, 5) = "RRULE" Cells(r, 9) = dtStr Case Left(line, 13) = "LAST-MODIFIED" Cells(r, 10) = Format(ParseDateZ(dtStr), "yyyy-mm-dd hh:mm ![]() Case Left(line, 8) = "LOCATION" Cells(r, 11) = dtStr Case Left(line, 8) = "SEQUENCE" Cells(r, 12) = dtStr Case Left(line, 6) = "STATUS" Cells(r, 13) = dtStr Case Left(line, 7) = "SUMMARY" Cells(r, 14) = dtStr Case Left(line, 6) = "TRANSP" Cells(r, 15) = dtStr Case Left(line, 10) = "END:VEVENT" r = r + 1 End Select Else lineCount = lineCount + 1 End If 'EventStart line = objStream.ReadText(adReadLine) Loop Cells(r + 2, 1) = lineCount & " Headerzeilen" Columns(1).NumberFormat = "dd.mm.yyyy" Columns(2).NumberFormat = "hh:mm ![]() Columns(3).NumberFormat = "dd.mm.yyyy" Columns(4).NumberFormat = "hh:mm ![]() 'eigentlich nicht notwendig: Columns(5).NumberFormat = "yyyy-mm-dd hh:mm ![]() Columns(7).NumberFormat = "yyyy-mm-dd hh:mm ![]() Columns(10).NumberFormat = "yyyy-mm-dd hh:mm ![]() Dim Spalte As Range For Each Spalte In ActiveSheet.UsedRange.Columns Spalte.AutoFit Next Spalte End Sub Function ParseDateZ(dtStr As String) Dim dtArr() As String Dim dt As Date dtArr = Split(Replace(dtStr, "Z", ""), "T") dt = DateSerial(Left(dtArr(0), 4), Mid(dtArr(0), 5, 2), Right(dtArr(0), 2)) If UBound(dtArr) > 1 Then dt = dt + TimeSerial(Left(dtArr(1), 2), Mid(dtArr(1), 3, 2), Right(dtArr(1), 2)) End If ParseDateZ = dt End Function |