Kleiner Nachtrag,
Mail als gelesen markieren, damit nicht mehrere Termine erstellt werden
VG KH
Option Explicit
'Dieses Ereignis tritt auf, wenn eine oder mehrere Mails erhalten wurden
Private Sub Application_NewMail()
Dim oItems As Object, oMail As Object
With GetNamespace("MAPI").Folders("voltmann-khan@t-online.de").Folders("Posteingang").Items
'Nach ungelesenen Mails filtern
Set oItems = .Restrict("[UnRead] = True")
Call oItems.Sort("SentOn") 'aufsteigend sortieren nach Datum
For Each oMail In oItems
If TypeOf oMail Is Outlook.MailItem Then 'Nur Mails, keine Termine
If oMail.Subject Like "*Information MAIL*" Then
Call SetzeTermin(oMail, CreateItem(1)) 'Termin aus Mail erstellen
oMail.UnRead = False
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
'Mail bearbeiten
With oMail
Call CallByName(objHTML, "writeln", VbMethod, .HTMLBody)
'Terminelemente aus der Mail-Tabelle extrahieren
Set oNode = objHTML.DocumentElement.getElementsByTagName("TABLE")(0)
If Not oNode Is Nothing Then
'Namen des Antragstellers als Betreff extrahieren
sBetreff = Split(oNode.PreviousSibling.innerText & vbCrLf, vbCrLf)(1)
sBetreff = Split(sBetreff & " for ", " for ")(1)
'Zeiten extrahieren
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
'Jetzt den Termin erstellen
With oTermin
.Start = Format(sStart, "dd.mm.yyyy") & " " & sTime 'Startdatum und Uhrzeit
.End = Format(sEnde, "dd.mm.yyyy") & " " & sTime 'Endedatum und Uhrzeit
.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 Sub
|