So, habe mich noch mal hingesetzt und das weiter gesponnen.
Für Outlook: ungetestet (nur Ausgabe - Terminerstellung fehlt noch)
'#####################################
' Klassenmodul: ThisOutlookSession
'#####################################
'#
'# version: 0.1.0
'# author: Trägheit
'# date: 09.10.2020
'#
'# benötigt Verweis auf:
'# * 'Microsoft HTML Object Library'
'#
Option Explicit
Private Type MailDataType
AcceptanceDate As Date
RequestDate As Date
StartDate As Date
EndDate As Date
DurationPerDay As Integer
RequestFor As String
End Type
'#####################################
'# Dieses Ereignis tritt ein, wenn eine oder mehrere Mails erhalten wurden
'# (Mails = Termine, Terminserien, Aufgabe, Text-Mail, usw.)
Private Sub Application_NewMail()
Dim objItems As Outlook.Items
Set objItems = GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Items
'nach ungelesenen MailItems filtern
Set objItems = objItems.Restrict("[UnRead] = True AND [MessageClass] = 'IPM.Note'")
'aufsteigend sortieren nach Datum
' (Items müssen sortiert werden; ihre Reihenfolge ist sonst unbestimmt)
Call objItems.Sort("SentOn")
Dim objMailItem As Outlook.MailItem
Dim udtMailData As MailDataType
For Each objMailItem In objItems
udtMailData = EmptyMailDataType()
If GetMailData(objMailItem.HTMLBody, udtMailData) Then
'Ausgabe - hier käme dann die Erstellung des Termins / Kalendereintrags
Debug.Print String(15, "-")
Debug.Print "AcceptanceDate: "; udtMailData.AcceptanceDate
Debug.Print " RequestDate: "; udtMailData.RequestDate
Debug.Print " RequestFor: "; "'"; udtMailData.RequestFor; "'"
Debug.Print " From: "; DateValue(udtMailData.StartDate); "(Start: "; TimeValue(udtMailData.StartDate); ")"
Debug.Print " To: "; udtMailData.EndDate
'als gelesen markieren
' objMailItem.UnRead = False
' Call MsgBox("Laden der Daten war erfolgreich.", vbInformation)
Else
' Call MsgBox("Laden der Daten ist leider fehlgeschlagen.", vbExclamation)
End If
Next
End Sub
'#####################################
'# Läd HTML und sucht HTML Tabelle für den Einsprung zum Lesen der Daten
Private Function GetMailData(MailContentHTML As String, ByRef MailData As MailDataType) As Boolean
Dim objHTML As MSHTML.HTMLDocument
Set objHTML = New MSHTML.HTMLDocument
Call CallByName(objHTML, "writeln", VbMethod, MailContentHTML)
With objHTML.DocumentElement
With .getElementsByTagName("TABLE")
If .Length > 0 Then
GetMailData = FetchMailData(.Item(0), MailData)
End If
End With
End With
End Function
'#####################################
'# HTML Daten lesen, mit HTML Tabelle als Einsprungspunkt
Private Function FetchMailData(HTMLTable As MSHTML.HTMLTable, ByRef MailData As MailDataType) As Boolean
On Error GoTo ErrHandler
'# Daten oberhalb von HTMLTable lesen
With CreateObject("VBScript.RegExp")
.Global = True
.IgnoreCase = True
.MultiLine = True
Dim str As String
' "Acceptance date : 06/10/2020" -> '06/10/2020'
' "Request approuved for Max Mustermann" -> "Request approuved for : Max Mustermann" -> 'Max Mustermann'
' "Request Date : 06/10/2020" -> '06/10/2020'
str = HTMLTable.PreviousSibling.innerText
' "Request approuved for Max Mustermann" -> "Request approuved for : Max Mustermann" -> 'Max Mustermann'
.Pattern = "\bfor\b"
str = .Replace(str, "for :")
' "Acceptance date : 06/10/2020" -> '06/10/2020'
' "Request approuved for : Max Mustermann" -> 'Max Mustermann'
' "Request Date : 06/10/2020" -> '06/10/2020'
.Pattern = ":\s*\b(.+)\b$"
With .Execute(str)
MailData.AcceptanceDate = DateConv(DateValue(.Item(0).SubMatches(0)))
MailData.RequestFor = .Item(1).SubMatches(0)
MailData.RequestDate = DateConv(DateValue(.Item(2).SubMatches(0)))
End With
End With
'# Daten aus von HTMLTable lesen
Dim tableRow As MSHTML.HTMLTableRow
Dim tableCell As MSHTML.HTMLTableCell
Dim i As Long
With HTMLTable.Rows(1).Cells '1 = zweite Zeile in Tabelle
For i = 0 To .Length - 1
'Wertezuweisung anhand Spaltenindex
Select Case i
Case 0 'Startdate
MailData.StartDate = DateConv(.Item(i).innerText)
Case 1 'Enddate
MailData.EndDate = DateConv(.Item(i).innerText)
Case 2 'Duration (per day)
MailData.DurationPerDay = Trim(.Item(i).innerText)
Case 3 'Starttime
MailData.StartDate = MailData.StartDate + TimeValue(.Item(i).innerText)
End Select
Next
End With
FetchMailData = True
Exit Function
ErrHandler:
FetchMailData = False
MailData = EmptyMailDataType()
End Function
'#####################################
'# Datums-Format handhaben
Private Function DateConv(Expr As String) As Date
With CreateObject("VBScript.RegExp")
.Pattern = "(\d{2})/(\d{2})/(\d{4})"
'#MM/DD/YYYY# #YYYY-MM-DD#
' 06/10/2020' => 2020-06-10
DateConv = DateValue(.Replace(Expr, "$3-$2-$1"))
End With
End Function
'#####################################
'#
Private Function EmptyMailDataType() As MailDataType
'nix zu tun hier - cool! :]
End Function
|