Sub
OL_Termin_Aus_Mail_Einstellen()
Dim
oOLApp
As
Object
, oTermin
As
Object
Dim
i
As
Integer
, j
As
Integer
, sArr()
As
String
Dim
sZeit
As
String
, sStart
As
String
, sEnd
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
sArr = Split(sMailtext, vbLf)
If
sMailtext <>
""
Then
For
j = 0
To
UBound(sArr)
If
Trim$(sArr(j))
Like
"Starttime*"
Then
Exit
For
Next
j
sStart = Trim$(Replace(sArr(j + 2), vbLf,
""
))
sEnd = Trim$(Replace(sArr(j + 4), vbLf,
""
))
sZeit = Trim$(Replace(sArr(j + 8), vbLf,
""
))
Set
oTermin = oOLApp.CreateItem(1)
With
oTermin
.Start = Format(sStart,
"dd.mm.yyyy"
) &
" "
& sZeit
.
End
= Format(sEnd,
"dd.mm.yyyy"
) &
" "
& sZeit
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