Office-Fragen.de

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/questio...s-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 Confused

s")
'Spalte "TIMESTART"
Cells(r, 2) = Cells(r, 1)
Case Left(line, 5) = "DTEND"
Cells(r, 3) = Format(ParseDateZ(dtStr), "yyyy-mm-dd hh:mm Confused

s")
'Spalte "TIMEEND"
Cells(r, 4) = Cells(r, 3)
Case Left(line, 7) = "DTSTAMP"
Cells(r, 5) = Format(ParseDateZ(dtStr), "yyyy-mm-dd hh:mm Confused

s")
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 Confused

s")
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 Confused

s")
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 Confused

s"
Columns(3).NumberFormat = "dd.mm.yyyy"
Columns(4).NumberFormat = "hh:mm Confused

s"
'eigentlich nicht notwendig:
Columns(5).NumberFormat = "yyyy-mm-dd hh:mm Confused

s"
Columns(7).NumberFormat = "yyyy-mm-dd hh:mm Confused

s"
Columns(10).NumberFormat = "yyyy-mm-dd hh:mm Confused

s"
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

Carsten-Wählisch