Hallo,

scheint gut auszusehen.

Hier noch mal ein kleines Update, schau mal, ob das besser funktioniert. Hast Du vielleicht ein englisches Outlook, dass da was mit dem Datumsformat nicht stimmt?

Wenn das dann auch nicht passt, kannst Du mir so eine Mail als eMail zusenden.

Option Explicit
 
'Dieses Ereignis tritt auf, wenn eine oder mehrere Mails erhalten wurden
Private Sub Application_NewMail()
   
 Dim oItems As Object, oMail As Object
   
  With GetNamespace("MAPI").Folders("voltmann-khan@t-online.de").Folders("Posteingang").Items
   
'Nach ungelesenen Mails filtern
    Set oItems = .Restrict("[UnRead] = True")
    Call oItems.Sort("SentOn")                          'aufsteigend sortieren nach Datum
   
    For Each oMail In oItems
       
       If TypeOf oMail Is Outlook.MailItem Then         'Nur Mails, keine Termine
          If oMail.Subject Like "*Information MAIL*" Then
             Call SetzeTermin(oMail)                    'Termin aus Mail erstellen
             oMail.UnRead = False
          End If
       End If
    
    Next oMail
  
  End With
End Sub

Sub SetzeTermin(oMail As Object)
 Dim objHTML As MSHTML.HTMLDocument
 Dim oNode As Object, sArr() As String, iSpalte As Long
 Dim sStart As String, sEnde As String, sTime As String, sBetreff As String
 
 Set objHTML = New MSHTML.HTMLDocument
 
'Mail bearbeiten
 With oMail
   Call CallByName(objHTML, "writeln", VbMethod, .HTMLBody)
  
'Terminelemente aus der Mail-Tabelle extrahieren
   Set oNode = objHTML.DocumentElement.getElementsByTagName("TABLE")(0)
   If Not oNode Is Nothing Then

'Namen des Antragstellers  als Betreff extrahieren
      sBetreff = Split(oNode.PreviousSibling.innerText & vbCrLf, vbCrLf)(1)
      sBetreff = Split(sBetreff & " for ", " for ")(1)
      
'Zeiten extrahieren
      For iSpalte = 0 To oNode.rows(1).cells.Length - 1 'Spaltenanzahl aus zweiter Zeile ermitteln
        With oNode.rows(1).cells(iSpalte)               '2. Zeile enthält die Werte
          Select Case Trim$(oNode.rows(0).cells(iSpalte).innerText)
          Case "Startdate": sStart = Trim$(.innerText)
          Case "Enddate":   sEnde = Trim$(.innerText)
          Case "Starttime": sTime = Trim$(.innerText)
          End Select
        End With
      Next iSpalte
   
   End If
   
 End With
 
'Jetzt den Termin erstellen
 With CreateItem(1)
   .Start = DateValue(sStart) & " " & TimeValue(sTime)  'Startdatum und Uhrzeit
   .End = DateValue(sEnde) & " " & TimeValue(sTime)     'Endedatum und Uhrzeit
   .Subject = sBetreff                                  'Betreff einfügen
   .Body = "Termin für " & sBetreff                     'Body-Angaben
   .Location = "Ort nicht angegeben"                    'Ggf. Ort hinzufügen
   .Save                                                'Termin speichern
   .Display                                             'und anzeigen
 End With
End Sub

viele Grüße

Karl-Heinz