Hallo,
ich konnte mir die Mail mit dem o.a. HTML-Text erfolgreich zusenden. Anliegend mal ein (erster) geänderter Ansatz, aus dem Du aus so einer Mail dann den Termin erstellen könntest.
Die Einbettung in das Outlook-fähige Muster von Trägheit konnte ich noch nicht umsetzen, da ich jetzt weg muss und bis Sonntag abend offline bin.
Solltest Du bis dahin keinen eigenen Erfolg haben oder anderweitig Hilfe erfahren, können wir das dann gerne ab Montag forsetzen.
Ein schönes Wochenende
Karl-Heinz
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
'Outlook-Instance holen bzw. neu anlegen, falls keine offen
Set oOLApp = GetObject(vbNullString, "Outlook.Application")
If oOLApp Is Nothing Then
Set oOLApp = CreateObject("Outlook.Application")
End If
' With oOLApp.GetNamespace("MAPI").getdefaultfolder(6) '6=olFolderInbox
With oOLApp.GetNamespace("MAPI").Folders("voltmann-khan@t-online.de").Folders("Posteingang")
'Durchläuft alle Mails bzw. aktuell nur die letzte Mail
For i = .Items.Count To .Items.Count
With .Items(i)
sAbsender = .SenderName
sMailtext = .body
'Erstellt einen Outlook-Termin
If .Subject Like "Information MAIL*" And .unread = True Then 'Nur ungelesene Mail mit diesem Betreff nehmen
On Error Resume Next
sArr = Split(sMailtext, vbLf) 'Zeiten aus der Mail extrahieren
If sMailtext <> "" Then
For j = 0 To UBound(sArr)
If Trim$(sArr(j)) Like "Starttime*" Then Exit For
Next j
'Zeiten extrahieren
sStart = Trim$(Replace(sArr(j + 2), vbLf, "")) 'Startdatum
sEnd = Trim$(Replace(sArr(j + 4), vbLf, "")) 'Endedatum
sZeit = Trim$(Replace(sArr(j + 8), vbLf, "")) 'Zeit
Set oTermin = oOLApp.CreateItem(1) 'Kalendereintrag referenzieren
With oTermin
.Start = Format(sStart, "dd.mm.yyyy") & " " & sZeit 'Startdatum und Uhrzeit
.End = Format(sEnd, "dd.mm.yyyy") & " " & sZeit 'Endedatum und Uhrzeit
sBetreff = Trim$(Split(.Subject & " for ", " for ")(1)) 'Namen aus Betreff extrahieren
.Subject = sBetreff 'Betreff einfügen
.body = "Termin für " & sBetreff 'Body-Angaben
.Location = "Ort nicht angegeben" 'Ggf. Ort hinzufügen
.Save 'Termin speichern
.Display 'und anzeigen
End With
Set oTermin = Nothing
End If
End If
End With
Next i
End With
Set oOLApp = Nothing
End Sub
|