' Im Modul DieseOutlookSitzung (ThisOutlookSession)
 
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
  Call MN.neue_mail(EntryIDCollection)
  GL.close_XL   ' Excel speichern und schließen
End Sub
 
Private Sub Application_Startup()
  Dim Oi As Object
  Dim Of As Object
  Dim c As Long     ' Zähler für ungelesene Mails
 
  ' Für jedes Postfach
  For Each Of In Outlook.Session.Folders
    ' Fehler Pop-Up wird unterdrückt
    On Error Resume Next
    c = Of.Folders("Inbox").UnReadItemCount
    ' -> Führt zum Fehler, wenn der Mailserver nicht erreicht wird
    If Err.Number = 0 Then  ' es liegt kein Fehler vor
      On Error GoTo 0   ' Fehler Pop-Up wird re-aktiviert
      ' Für jede Mail im Ordner Inbox
      For Each Oi In Of.Folders("Inbox").Items
        If Oi.UnRead Then
          If TypeName(Oi) = "MailItem" Then
            MN.neue_mail Oi.EntryID
          End If
          c = c - 1
          If c = 0 Then Exit For
        End If
      Next Oi
    End If
  Next Of
  ' Fehler Pop-Up wird re-aktiviert
  On Error GoTo 0
 
  ' Excel speichern und schließen
  GL.close_XL
End Sub
 
Private Sub Application_Quit()
  GL.close_XL   ' Excel speichern und schließen
  If Not NS Is Nothing Then Set NS = Nothing
End Sub

Option Explicit
 
Global NS As Outlook.NameSpace
Global Stmp As String           ' * allgemeine Variable für Texte
Global XL As Excel.Application
Global XW As Excel.Workbook
Global XS As Excel.Worksheet
 
Sub set_namespace()
  Set NS = Outlook.GetNamespace("MAPI")
End Sub
 
Sub set_XL()
  On Error Resume Next
  Set XL = GetObject(, "Excel.Application")
  If XL Is Nothing Then
    Set XL = CreateObject("Excel.Application")
  End If
  On Error GoTo 0
End Sub
 
Sub close_XL()
  If Not XS Is Nothing Then
    Set XS = Nothing
    If Not XW Is Nothing And XW.FullName = "c:\test\Wolle\Beispiel.xls" Then
      XW.Close True     ' speichern + schließen der Datei Beispiel.xls
    End If
    For Each XW In XL.Workbooks     ' prüfen, ob es versteckte Workbooks gibt
      If XL.Windows(XW.Name).Visible Then Exit For
    Next XW
    If XW Is Nothing Then   ' Es gibt keine sichtbaren Workbooks
      For Each XW In XL.Workbooks
        XW.Close True   ' speichern + schließen der versteckten Workbooks
      Next XW
      XL.Quit   ' Beenden von Excel
      Set XL = Nothing
    End If
  End If
End Sub

Option Explicit
 
Sub neue_mail(sID As String)
  Dim mIt As Outlook.MailItem   ' 1)
  ' Weitere Deklaration - gehört nach oben in den Deklarationsteil
  Dim i As Long   ' findet die Anfangs-Position im Text
  Dim j As Long   ' findet die End-Position im Text
  Dim d As Date   ' Datum der Mail
  Dim w As String ' Wer spielt weiß
  Dim s As String ' wer spielt schwarz
  Dim e As String ' Ergebnis
  Dim h As String ' Hyperlink
  Dim p As Long   ' Meine Punkte nach dem Spiel
  ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  ' Ende Deklaration
  ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  If NS Is Nothing Then GL.set_namespace    ' 2)
  Stmp = TypeName(NS.GetItemFromID(sID))
  If Stmp = "MailItem" Then
    Set mIt = NS.GetItemFromID(sID)     ' 3)
  Else
    MsgBox "Die neue Mail ist vom unerwarteten Typ " & vbLf & Stmp & vbLf & _
      " und kann mit dem existierenden Makro nicht verarbeitet werden.", _
      vbCritical, "Abbruch"
    Exit Sub
  ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  ' Ende Block 1 - Die Mail ist identifiziert
  ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
  If mIt.SenderName <> "jepi@gmx.net" Then Exit Sub
  i = InStr(mIt.Body, vbCrLf & vbCrLf & "Sehr geehrter ")
  If i = 0 Then Exit Sub
 
  ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
  i = i + Len(vbCrLf & vbCrLf & "Sie haben  ")
  ' i - Das ist jetzt die Position rechts von "Sie haben jetzt "
 
  j = InStr(i, mIt.Body, " Punkte")
  ' Der Text zwischen den Positionen i und j enthält jetzt
  ' die Punktzahl
  ' MsgBox ">" & Mid(mIt.Body, i, j - i) & "<"
  ' nun wird dieser Text in eine Zahl vom Typ Long in
  ' Variable p gespeichert
 
  p = CLng(Mid(mIt.Body, i, j - i))
  ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  ' Ende Block 2 - Die Mail hat den gesuchten Inhalt
  ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
  d = mIt.CreationTime
  i = InStr(mIt.Body, "Sicherung ") + 1 ' hinter Spielbrett
  i = InStr(i, mIt.Body, Chr(34)) + 1    ' steht die Paarung in
  j = InStr(i, mIt.Body, Chr(34))        ' Gänsefüßchen chr(34)="
  Stmp = Mid(mIt.Body, i, j - i)
 
  ' "Split" teilt den String am zweiten Argument, hier "-"
  w = Split(Stmp, "-")(0)
 
  ' In unserem Fall ergibt Split zwei Teile
  s = Split(Stmp, "-")(1)
 
  i = InStr(mIt.Body, "HYPERLINK ") + Len("HYPERLINK ")
 
  i = InStr(i, mIt.Body, Chr(34)) + 1    ' steht die Paarung in
  j = InStr(i, mIt.Body, "Sicherung")
  j = InStr(i, mIt.Body, Chr(34))        ' Gänsefüßchen chr(34)="
  h = Mid(mIt.Body, i, j - i)
 
  If InStr(mIt.Body, "Erfolgreich") Then
    e = "OK"
  ElseIf InStr(mIt.Body, "Fehlerhaft") Then
    e = "Fehler"
  Else
    e = "Kein Mail"
  End If
  ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  ' Ende Block 3 - alle Werte, die nach Excel geschrieben
  ' werden müssen liegen jetzt in einzelnen Variablen vor.
  ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  ' ...
  ' ...
  ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  ' Ende Block 3 - alle Werte, die nach Excel geschrieben
  ' werden müssen liegen jetzt in einzelnen Variablen vor.
  ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  mIt.UnRead = False
  Stmp = ""
  For i = 1 To mIt.Parent.Folders.Count()
    If mIt.Parent.Folders(i).Name = "Erledigt" Then
      Stmp = "OK"
      Exit For
    End If
  Next i
  If Len(Stmp) = 0 Then mIt.Parent.Folders.Add "Erledigt"
  mIt.Move mIt.Parent.Folders("Erledigt")
  Set mIt = Nothing
  ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  ' Ende Block 4 - Mit der Mail sind wir fertig
  ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  ' ...

  ' ...
  ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  ' Ende Block 4 - Mit der Mail sind wir fertig
  ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  If XL Is Nothing Then GL.set_XL
  XL.Visible = True
  For Each XW In XL.Workbooks
    If XW.FullName = "c:\test\Wolle\Beispiel.xls" Then
      Exit For
    End If
  Next XW
  If XW Is Nothing Then
    Set XW = XL.Workbooks.Open("c:\test\Wolle\Beispiel.xls")
  End If
  XW.Activate
  Set XS = XW.Worksheets("Ergebnisse")
  XS.Activate
  XS.Select
  ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  ' Ende Block 5 - Excel ist bereit
  ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  ' ...
  ' ...
  ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  ' Ende Block 5 - Excel ist bereit
  ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  i = XL.WorksheetFunction.CountA(XS.Columns(1)) + 1
  XS.Cells(i, 1) = d ' Datum
  XS.Cells(i, 2) = w ' Weiss
  XS.Cells(i, 3) = s ' Schwarz
  XS.Cells(i, 4).Hyperlinks.Add e, h
  XS.Cells(i, 5) = p
End Sub