Option
Explicit
Private
Sub
Application_NewMail()
Dim
oItems
As
Object
, oMail
As
Object
With
GetNamespace(
"MAPI"
).Folders(
"voltmann-khan@t-online.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)
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
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
CreateItem(1)
.Start = DateValue(sStart) &
" "
& TimeValue(sTime)
.
End
= DateValue(sEnde) &
" "
& TimeValue(sTime)
.Subject = sBetreff
.Body =
"Termin für "
& sBetreff
.Location =
"Ort nicht angegeben"
.Save
.Display
End
With
With
CreateItem(0)
.BodyFormat = 2
.
To
=
"MeinEmpfaenger@Mail.de;Nocheiner@Mail.de"
.Subject = sBetreff
.GetInspector
.HTMLBody =
"<span style='font-family:Arial; font-size:10pt;color:#000000'>"
_
&
"Hallo,<br><br>hier der Termin:<br><br>"
_
&
"<table border=0 cellpadding=0 cellspacing=0>"
_
&
"<tr><td>Starttermin:</td><td> </td><td>"
& sStart &
"</td></tr>"
_
&
"<tr><td>Endtermin:</td><td> </td><td>"
& sEnde &
"</td></tr>"
_
&
"</table><br></span>"
& .HTMLBody
.Display
End
With
End
Sub