Option
Explicit
Private
Sub
Application_NewMail()
Dim
oItems
As
Object
, oMail
As
Object
With
GetNamespace(
"MAPI"
).Folders(
"volti@mail.de"
).Folders(
"Posteingang"
).Items
Set
oItems = .Restrict(
"[UnRead] = True"
)
Call
oItems.Sort(
"SentOn"
)
For
Each
oMail
In
oItems
If
TypeOf
oMail
Is
Outlook.MailItem
Then
If
oMail.Subject
Like
"*Information MAIL*"
Then
Call
SetzeTermin(oMail, CreateItem(1))
End
If
End
If
Next
oMail
End
With
End
Sub
Sub
SetzeTermin(oMail
As
Object
, oTermin
As
Object
)
Dim
objHTML
As
MSHTML.HTMLDocument
Dim
oNode
As
Object
, sArr()
As
String
Dim
iSpalte
As
Long
Dim
sStart
As
String
, sEnde
As
String
, sTime
As
String
Dim
sBetreff
As
String
Set
objHTML =
New
MSHTML.HTMLDocument
With
oMail
Call
CallByName(objHTML,
"writeln"
, VbMethod, .HTMLBody)
Set
oNode = objHTML.DocumentElement.getElementsByTagName(
"TABLE"
)(0)
If
Not
oNode
Is
Nothing
Then
sBetreff = Split(oNode.PreviousSibling.innerText & vbCrLf, vbCrLf)(1)
sBetreff = Split(sBetreff &
" for "
,
" for "
)(1)
For
iSpalte = 0
To
oNode.rows(1).cells.Length - 1
With
oNode.rows(1).cells(iSpalte)
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
With
oTermin
.Start = Format(sStart,
"dd.mm.yyyy"
) &
" "
& sTime
.
End
= Format(sEnde,
"dd.mm.yyyy"
) &
" "
& sTime
.Subject = sBetreff
.Body =
"Termin für "
& sBetreff
.Location =
"Ort nicht angegeben"
.Save
.Display
End
With
Set
oTermin =
Nothing
End
Sub