Option
Explicit
Option
Compare Text
Sub
OL_Termin_Aus_Mail_Einstellen()
Dim
oOLApp
As
Object
, oTermin
As
Object
Dim
i
As
Integer
, j
As
Integer
, sArr()
As
String
, T
As
String
Dim
sBetreff
As
String
, sAbsender
As
String
, sMailtext
As
String
Set
oOLApp = GetObject(vbNullString,
"Outlook.Application"
)
If
oOLApp
Is
Nothing
Then
Set
oOLApp = CreateObject(
"Outlook.Application"
)
End
If
With
oOLApp.GetNamespace(
"MAPI"
).Folders(
"voltmann-khan@t-online.de"
).Folders(
"Posteingang"
)
For
i = .Items.Count
To
.Items.Count
With
.Items(i)
sAbsender = .SenderName
sMailtext = .Body
If
.Subject
Like
"Information MAIL*"
And
.UnRead =
True
Then
On
Error
Resume
Next
sMailtext = Split(sMailtext,
"Start time"
)(1)
sMailtext = Split(sMailtext,
"Applicant"
)(0)
If
sMailtext <>
""
Then
sArr = Split(Trim$(sMailtext) &
" "
)
Set
oTermin = oOLApp.CreateItem(1)
With
oTermin
.Start = Format((sArr(0)),
"dd.mm.yyyy"
) &
" "
& sArr(3)
.
End
= Format((sArr(1)),
"dd.mm.yyyy"
) &
" "
& sArr(3)
sBetreff = Trim$(Split(.Subject &
" for "
,
" for "
)(1))
.Subject = sBetreff
.Body =
"Termin für "
& sBetreff
.Location =
"Ort nicht angegeben"
.Save
.Display
End
With
Set
oTermin =
Nothing
End
If
End
If
End
With
Next
i
End
With
Set
oOLApp =
Nothing
End
Sub