Excel VBA - Emailbody aus Outlook auslesen

Das ist jetzt mein vollständiger Code. Jetzt habe ich natürlich im Netz geguckt, wie ich den Betreff und das Datum der Mail auslesen kann. Das klappt auch. ABER. Er nimmt jetzt nur die Mails in meinem Hauptpostfach und nicht mehr aus dem Test Ordner.

Visual Basic:
For Each olMail In olFolder.Items        

        If olMail.Subject Like "*Auswertung Resa ausgehende Emails" Then

Das ist der Teil, wo ich auf die Teile der Email zugreife. In dem Code unten wird ja auch auf die Email zugegriffen. Wie kann ich jetzt das so nutzen, dass ich nicht doppelt auf die Mail zugreife, sodass er auch im Ordner Test bleibt und nicht im Hauptordner.


Visual Basic:
Dim otl As Outlook.Application
    Dim ns As Outlook.Namespace
    Dim fld As Outlook.MAPIFolder
    Dim mail As Outlook.MailItem
    Dim f As Long
    Dim letzte As Long
    Dim letzte2 As Long
    Dim ziel As Worksheet
    Dim ziel2 As Worksheet
    Dim olFolder As Object
    Dim olMail As Object
    Dim olApp As Object
    Dim match As Object
    Dim Items As Object

    
    Set olApp = CreateObject("Outlook.Application")
    Set otl = New Outlook.Application
    Set ns = otl.GetNamespace("MAPI")
    Set fld = ns.Folders(C_MAPI).Folders(C_FOLDER)
    Set mail = fld.Items.GetFirst
    Set ziel = ThisWorkbook.Worksheets("Gesamt Eingang")
    Set ziel2 = ThisWorkbook.Worksheets("Gesamt Ausgang")
    Set olFolder = olApp.ActiveExplorer.CurrentFolder
    
    'RegExp definieren
    Dim rx As Object
    
    Set rx = CreateObject("VBScript.RegExp")
    
    rx.Pattern = "\b([\w.%+-]+@[\w.-]+\.[A-Z]{2,})\b(?: <mailto:[\w.%+-]+@[\w.-]+\.[A-Z]{2,}>)?\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+)"
    rx.ignoreCase = True
    rx.Global = True
    
    'Prüfen ob der Body eine Tabelle enthält
    If Not rx.test(mail.Body) Then
        MsgBox "Mailbody passt nicht"
        Exit Sub
    End If
    
    For Each olMail In olFolder.Items
        
        If olMail.Subject Like "*Auswertung Resa ausgehende Emails" Then
            
           'Mit dem RegEx die einzelnen Zeilen auslsen
          
           letzte = Sheets("Gesamt Eingang").UsedRange.SpecialCells(xlCellTypeLastCell).Row
                
           For Each match In rx.Execute(mail.Body)
           Set Items = match.SubMatches
           '//TODO: Anstelle des debug.print diese in eine neie Zeile eines Excelsheets schreiben
          
               ziel.Range("A" & letzte).Value = Format(olMail.ReceivedTime, "DD.MM.YYYY") - 1
               ziel.Range("B" & letzte).Value = Items(0)
               ziel.Range("C" & letzte).Value = Items(1)
               ziel.Range("D" & letzte).Value = Items(2)
               ziel.Range("E" & letzte).Value = Items(3)
               ziel.Range("F" & letzte).Value = Items(4)
               ziel.Range("G" & letzte).Value = Items(5)
              
               letzte = letzte + 1
        
           Next match
        
        ElseIf olMail.Subject Like "*Auswertung Resa eingehende Emails" Then
            
        'Mit dem RegEx die einzelnen Zeilen auslsen
        
           letzte2 = Sheets("Gesamt Ausgang").UsedRange.SpecialCells(xlCellTypeLastCell).Row
                
           For Each match In rx.Execute(mail.Body)
           Set Items = match.SubMatches
           '//TODO: Anstelle des debug.print diese in eine neie Zeile eines Excelsheets schreiben
          
               ziel2.Range("A" & letzte2).Value = Format(olMail.ReceivedTime, "DD.MM.YYYY") - 1
               ziel2.Range("B" & letzte2).Value = Items(0)
               ziel2.Range("C" & letzte2).Value = Items(1)
               ziel2.Range("D" & letzte2).Value = Items(2)
               ziel2.Range("E" & letzte2).Value = Items(3)
               ziel2.Range("F" & letzte2).Value = Items(4)
               ziel2.Range("G" & letzte2).Value = Items(5)
              
               letzte2 = letzte2 + 1
        
           Next match
        
        End If
    
        
    Next
 
Copy & Paste ergibt Chaos. Wenn man Codeschnipsel zusammenführt, sollte man die Variabeln anpassen.

Du nimmst mail aus dem Test-folder, prüfst ob der Mailbody passt.
Anschliessend alle Mails aus oFolder durch, was dein aktueller Ordner im Outlook ist.
Arbeiten tust du aber immer nur mit dem einen Mail

Warum?
Visual Basic:
'dein Ablauf gekürzt (kein Code)
Set mail = fld.Items.GetFirst    'Erstes Mail aus C_FOLDER
If Not rx.test(mail.Body) Then ....

Set olFolder = olApp.ActiveExplorer.CurrentFolder
For Each olMail In olFolder.Items  'Also die Mails aus dem offenen Outlookordner, ev der Posteingang
    ...
    If olMail.Subject Like "*Auswertung Resa ausgehende Emails" Then   'Prüfst auf olMail
       For Each match In rx.Execute(mail.Body)   'und nimmst den Body von immer demselben Mail aus, nicht von olMail

Entweder arbeitest du mit mail oder mit olMail. Auf alle Fälle solltest du sie aus fld auslesen und nicht aus olApp....CurrentFolder.
 
Copy & Paste ergibt Chaos. Wenn man Codeschnipsel zusammenführt, sollte man die Variabeln anpassen.

Du nimmst mail aus dem Test-folder, prüfst ob der Mailbody passt.
Anschliessend alle Mails aus oFolder durch, was dein aktueller Ordner im Outlook ist.
Arbeiten tust du aber immer nur mit dem einen Mail

Warum?
Visual Basic:
'dein Ablauf gekürzt (kein Code)
Set mail = fld.Items.GetFirst    'Erstes Mail aus C_FOLDER
If Not rx.test(mail.Body) Then ....

Set olFolder = olApp.ActiveExplorer.CurrentFolder
For Each olMail In olFolder.Items  'Also die Mails aus dem offenen Outlookordner, ev der Posteingang
    ...
    If olMail.Subject Like "*Auswertung Resa ausgehende Emails" Then   'Prüfst auf olMail
       For Each match In rx.Execute(mail.Body)   'und nimmst den Body von immer demselben Mail aus, nicht von olMail

Entweder arbeitest du mit mail oder mit olMail. Auf alle Fälle solltest du sie aus fld auslesen und nicht aus olApp....CurrentFolder.


Ok, das hat alles funktioniert und ich habe alles jetzt über mail laufen.
Aber er ließt nur eine Mail aus und schreibt sie in das Sheet.

Sobald aber eine 2te Mail im Postfach ist, dann überspringt er quasi das Eintragen der Daten.
Habe schon das Objekt match in match2 geändert, damit die if schleife ein eigenes Objekt hat.
Dazu hab ich geschaut, ob ich mit der msgbox auslesen kann ob er überhaupt den Betreff richtig ausließt. Das macht er auch. Und er springt auf in der if schleife in die richtige Zeile. überspringt dann aber das eintragen.

Visual Basic:
Option Explicit

Public Function xlsGetLastRow(ByRef sheet As Excel.Worksheet) As Long
    Dim r As Variant

    xlsGetLastRow = sheet.Cells.SpecialCells(xlCellTypeLastCell).Row
    For r = xlsGetLastRow To 1 Step -1
        If sheet.Application.WorksheetFunction.CountA(sheet.Rows(r)) = 0 Then
            xlsGetLastRow = r - 1
        Else
            Exit For
        End If
    Next r
End Function

Private Function lastRowNr(ByRef ws As Worksheet)
    lastRowNr = ws.UsedRange.SpecialCells(xlCellTypeLastCell).Row
End Function


Public Function xlsGetLastCol(ByRef sheet As Excel.Worksheet) As Long
    Dim i As Variant
    xlsGetLastCol = sheet.Cells.SpecialCells(xlCellTypeLastCell).Column
    For i = xlsGetLastCol To 1 Step -1
        If sheet.Application.WorksheetFunction.CountA(sheet.Columns(i)) = 0 Then
            xlsGetLastCol = i - 1
        Else
            Exit For
        End If
    Next i
End Function

Public Sub mailTest()
    Const C_MAPI = "J.Linden@xyz.de"
    Const C_FOLDER = "Test"
   
   
    'Das Test-Mail auslesen
    Dim otl As Outlook.Application
    Dim ns As Outlook.Namespace
    Dim fld As Outlook.MAPIFolder
    Dim mail As Outlook.MailItem
    Dim f As Long
    Dim letzte As Long
    Dim letzte2 As Long
    Dim ziel As Worksheet
    Dim ziel2 As Worksheet
    Dim olFolder As Object
    Dim olMail As Object
    Dim olApp As Object
    Dim match As Object
    Dim match2 As Object
    Dim Items As Object

   
    Set olApp = CreateObject("Outlook.Application")
    Set otl = New Outlook.Application
    Set ns = otl.GetNamespace("MAPI")
    Set fld = ns.Folders(C_MAPI).Folders(C_FOLDER)
    Set mail = fld.Items.GetFirst
    Set ziel2 = ThisWorkbook.Worksheets("Gesamt Eingang")
    Set ziel = ThisWorkbook.Worksheets("Gesamt Ausgang")
    Set olFolder = olApp.ActiveExplorer.CurrentFolder
   
    'RegExp definieren
    Dim rx As Object
   
    Set rx = CreateObject("VBScript.RegExp")
   
    rx.Pattern = "\b([\w.%+-]+@[\w.-]+\.[A-Z]{2,})\b(?: <mailto:[\w.%+-]+@[\w.-]+\.[A-Z]{2,}>)?\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+)"
    rx.ignoreCase = True
    rx.Global = True
   
    'Prüfen ob der Body eine Tabelle enthält
    If Not rx.test(mail.Body) Then
        MsgBox "Mailbody passt nicht"
        Exit Sub
    End If
   
    For Each mail In fld.Items
   
   
        MsgBox mail.Subject
       
        If mail.Subject Like "Auswertung Resa ausgehende Emails" Then
           
           'Mit dem RegEx die einzelnen Zeilen auslsen
         
           letzte = ziel.UsedRange.SpecialCells(xlCellTypeLastCell).Row
               
           For Each match In rx.Execute(mail.Body)
           Set Items = match.SubMatches
           '//TODO: Anstelle des debug.print diese in eine neie Zeile eines Excelsheets schreiben
         
               ziel.Range("A" & letzte).Value = mail.ReceivedTime
               ziel.Range("B" & letzte).Value = Items(0)
               ziel.Range("C" & letzte).Value = Items(1)
               ziel.Range("D" & letzte).Value = Items(2)
               ziel.Range("E" & letzte).Value = Items(3)
               ziel.Range("F" & letzte).Value = Items(4)
               ziel.Range("G" & letzte).Value = Items(5)
             
               letzte = letzte + 1
       
           Next match
       
        ElseIf mail.Subject Like "Auswertung Resa eingehende Emails" Then
           
        'Mit dem RegEx die einzelnen Zeilen auslsen
       
           letzte2 = ziel2.UsedRange.SpecialCells(xlCellTypeLastCell).Row
               
           For Each match2 In rx.Execute(mail.Body)
           Set Items = match2.SubMatches
           '//TODO: Anstelle des debug.print diese in eine neie Zeile eines Excelsheets schreiben
         
               ziel2.Range("A" & letzte2).Value = mail.ReceivedTime
               ziel2.Range("B" & letzte2).Value = Items(0)
               ziel2.Range("C" & letzte2).Value = Items(1)
               ziel2.Range("D" & letzte2).Value = Items(2)
               ziel2.Range("E" & letzte2).Value = Items(3)
               ziel2.Range("F" & letzte2).Value = Items(4)
               ziel2.Range("G" & letzte2).Value = Items(5)
             
               letzte2 = letzte2 + 1
       
           Next match2
       
        End If
   
       
    Next
   
End Sub
 
Ein Zusatz noch. bei der Mail die er dann in das Sheet schreibt passiert folgendes.
Wenn ich das noch mal durchlaufen lasse, dann schreibt er nicht in die letzte Zeile sonder überschreibt die Zeile davor und trägt dann die Tabelle ab da in das Sheet.
 
Wenn ich mir den Code noch mal anschaue, dann macht doch die Zeile 70 folgendes. Er sucht nach einer beliebigen Email. Wenn es aber nur 10 gibt die immer gleich sind, dann kann man diese doch fest definieren. Und dann sagen, alles was rechts daneben ist, soll er dann in das Array schreiben. Macht das Sinn?

Muss ich dann RegEx nutzen wenn ich alle Emailadressen weiß?
 
Chaos, das pure Chaos in deinem Code.
Zeile 70 definiert den Pattern des Regex. Der wählt kein Mail aus. Nix dergleichen.

Warum wählst du am Anfang das erste Mail aus, testest es gegen den Regex und machst weiter nix damit?
Anschliessend gehst du alle Mails durch, wendest den RegEx auf die Mails an ohne sie zu testen.
Dan überschreibt der erste Durchgang logischerweise die letzte Zeile, weil du diese ausliest und anwendest. Wenn du in einer neuen Zeile beginnen willst, dann solltest du die letzte Zeile+1 verwenden

Wozu hast du die Funktionen xlsGetLastCol() und xlsGetLastRow(), wenn du sie nicht brauchst?

Wozu soll oFolder gut sein? Du verwendest ihn nirgends

Wenn du 2 mal denselben Code-Abschnitt hast, dann gehört dieser teil in eine Funktion oder eine Sub.

Hier, das ganze mal aufgeräumt
Visual Basic:
Option Explicit

Public Sub mailTest()
    Const C_MAPI = "stefan.erb@axa-groupsolutions.com"
    Const C_FOLDER = "TEST"
   
    'Das Test-Mail auslesen
    Dim otl As Outlook.Application
    Dim ns As Outlook.Namespace
    Dim fld As Outlook.MAPIFolder
    Dim mail As Outlook.MailItem
   
    Set otl = New Outlook.Application
    Set ns = otl.GetNamespace("MAPI")
    Set fld = ns.Folders(C_MAPI).Folders(C_FOLDER)
   
    For Each mail In fld.Items
        If mail.Subject Like "*Auswertung Resa ausgehende Emails*" Then
            importMail ThisWorkbook.Worksheets("Gesamt Ausgang"), mail
        ElseIf mail.Subject Like "*Auswertung Resa eingehende Emails*" Then
            importMail ThisWorkbook.Worksheets("Gesamt Eingang"), mail
        End If
    Next
End Sub

'/**
' * Importiert ein Mail
' * @param  Worksheet       Zieltabelle, an  die die Daten angefügt werden
' * @param  Mail            Das Mail
' * @return Boolean         True: der Import war erfolgreich
' */'
Private Function importMail(ByRef ioWsZiel As Worksheet, ByRef iMail As Object) As Boolean
    Dim nextRowNr As Long
    Dim match As Object
    Dim Items As Object
    
    'Prüfen ob der Body eine Tabelle enthält
    If Not rxMailBody.test(iMail.body) Then
        MsgBox "Mailbody passt nicht"
        Exit Function
    End If

    nextRowNr = ioWsZiel.UsedRange.SpecialCells(xlCellTypeLastCell).row + 1
       

    For Each match In rxMailBody.Execute(iMail.body)
        Set Items = match.SubMatches
        ioWsZiel.Range("A" & nextRowNr).value = iMail.ReceivedTime
        ioWsZiel.Range("B" & nextRowNr).value = Items(0)
        ioWsZiel.Range("C" & nextRowNr).value = Items(1)
        ioWsZiel.Range("D" & nextRowNr).value = Items(2)
        ioWsZiel.Range("E" & nextRowNr).value = Items(3)
        ioWsZiel.Range("F" & nextRowNr).value = Items(4)
        ioWsZiel.Range("G" & nextRowNr).value = Items(5)
     
        nextRowNr = nextRowNr + 1
    Next match
    importMail = True
End Function

'/**
' * Verwaltet den RegEx
' * @return VBScript.RegExp
' */
Private Property Get rxMailBody() As Object
    Static rx As Object
    If rx Is Nothing Then
        Set rx = CreateObject("VBScript.RegExp")
        rx.Pattern = "\b([\w.%+-]+@[\w.-]+\.[A-Z]{2,})\b(?: <mailto:[\w.%+-]+@[\w.-]+\.[A-Z]{2,}>)?\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+)"
        rx.ignoreCase = True
        rx.Global = True
    End If
    Set rxMailBody = rx
End Property
 
Chaos, das pure Chaos in deinem Code.
Zeile 70 definiert den Pattern des Regex. Der wählt kein Mail aus. Nix dergleichen.

Warum wählst du am Anfang das erste Mail aus, testest es gegen den Regex und machst weiter nix damit?
Anschliessend gehst du alle Mails durch, wendest den RegEx auf die Mails an ohne sie zu testen.
Dan überschreibt der erste Durchgang logischerweise die letzte Zeile, weil du diese ausliest und anwendest. Wenn du in einer neuen Zeile beginnen willst, dann solltest du die letzte Zeile+1 verwenden

Wozu hast du die Funktionen xlsGetLastCol() und xlsGetLastRow(), wenn du sie nicht brauchst?

Wozu soll oFolder gut sein? Du verwendest ihn nirgends

Wenn du 2 mal denselben Code-Abschnitt hast, dann gehört dieser teil in eine Funktion oder eine Sub.

Hier, das ganze mal aufgeräumt
Visual Basic:
Option Explicit

Public Sub mailTest()
    Const C_MAPI = "stefan.erb@axa-groupsolutions.com"
    Const C_FOLDER = "TEST"
 
    'Das Test-Mail auslesen
    Dim otl As Outlook.Application
    Dim ns As Outlook.Namespace
    Dim fld As Outlook.MAPIFolder
    Dim mail As Outlook.MailItem
 
    Set otl = New Outlook.Application
    Set ns = otl.GetNamespace("MAPI")
    Set fld = ns.Folders(C_MAPI).Folders(C_FOLDER)
 
    For Each mail In fld.Items
        If mail.Subject Like "*Auswertung Resa ausgehende Emails*" Then
            importMail ThisWorkbook.Worksheets("Gesamt Ausgang"), mail
        ElseIf mail.Subject Like "*Auswertung Resa eingehende Emails*" Then
            importMail ThisWorkbook.Worksheets("Gesamt Eingang"), mail
        End If
    Next
End Sub

'/**
' * Importiert ein Mail
' * @param  Worksheet       Zieltabelle, an  die die Daten angefügt werden
' * @param  Mail            Das Mail
' * @return Boolean         True: der Import war erfolgreich
' */'
Private Function importMail(ByRef ioWsZiel As Worksheet, ByRef iMail As Object) As Boolean
    Dim nextRowNr As Long
    Dim match As Object
    Dim Items As Object
  
    'Prüfen ob der Body eine Tabelle enthält
    If Not rxMailBody.test(iMail.body) Then
        MsgBox "Mailbody passt nicht"
        Exit Function
    End If

    nextRowNr = ioWsZiel.UsedRange.SpecialCells(xlCellTypeLastCell).row + 1
     

    For Each match In rxMailBody.Execute(iMail.body)
        Set Items = match.SubMatches
        ioWsZiel.Range("A" & nextRowNr).value = iMail.ReceivedTime
        ioWsZiel.Range("B" & nextRowNr).value = Items(0)
        ioWsZiel.Range("C" & nextRowNr).value = Items(1)
        ioWsZiel.Range("D" & nextRowNr).value = Items(2)
        ioWsZiel.Range("E" & nextRowNr).value = Items(3)
        ioWsZiel.Range("F" & nextRowNr).value = Items(4)
        ioWsZiel.Range("G" & nextRowNr).value = Items(5)
   
        nextRowNr = nextRowNr + 1
    Next match
    importMail = True
End Function

'/**
' * Verwaltet den RegEx
' * @return VBScript.RegExp
' */
Private Property Get rxMailBody() As Object
    Static rx As Object
    If rx Is Nothing Then
        Set rx = CreateObject("VBScript.RegExp")
        rx.Pattern = "\b([\w.%+-]+@[\w.-]+\.[A-Z]{2,})\b(?: <mailto:[\w.%+-]+@[\w.-]+\.[A-Z]{2,}>)?\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+)"
        rx.ignoreCase = True
        rx.Global = True
    End If
    Set rxMailBody = rx
End Property


Danke schon mal für deine Hilfe.

Ich habe RegEx noch nie benutzt. Und kenn mich da nicht so aus.
Und weil dort mailto stand, bin ich davon ausgegangen, dass er in der Zeile nach einer Mail sucht.

Also das was nach dem pattern steht sucht quasi nur nach Wörtern und nicht nach Tabellen?
Wenn z. B. die Tabelle nicht 5 sondern nur noch 4 Spalten hat oder 3 dann findet er trotzdem noch alles?

Muss dann aber die importMail Funktion anpassen, dass er quasi nur so viel Items sucht wie auch vorhanden sind?
 
Zuletzt bearbeitet:
  • \b([\w.%+-]+@[\w.-]+\.[A-Z]{2,})\b(?: <mailto:[\w.%+-]+@[\w.-]+\.[A-Z]{2,}>)?: Mailadresse. Ev mit dem <mailto:> zusatz. Das sind die Felder, die einen Maillink haben
  • \s+(\d+) Leerzeichen und eine Zahl. Also ein Zahlenfled

Du kannst die Felder auch variabel machen. Also ein Maximum musst du schon definieren
Dazu ersetzt man \s+(\d+) durch (:\s+(\d+))?. Im folgenden Pattern habe ich jetzt bis zu 7 Felder
\b([\w.%+-]+@[\w.-]+\.[A-Z]{2,})\b(?: <mailto:[\w.%+-]+@[\w.-]+\.[A-Z]{2,}>)?(?:\s+(\d+))?(?:\s+(\d+))?(?:\s+(\d+))?(?:\s+(\d+))?(?:\s+(\d+))?(?:\s+(\d+))?(?:\s+(\d+))?

Test mit 7 definierten Feldern, aber nur 5 werden geliefert
Code:
print_r items
<ISubMatches>  (
    [#0] => <String> 'xyz@info.de'
    [#1] => <String> '1557'
    [#2] => <String> '0'
    [#3] => <String> '1557'
    [#4] => <String> '0'
    [#5] => <String> '0'
    [#6] => <Empty> 
    [#7] => <Empty> 
)
 
Hi,

das hat "natürlich alles geklappt".

Was ist denn, wenn bei manchen Emails keine Tabelle vorhanden ist aber trotzdem Werte benutzt werden sollen.

Wir z. B. :


Code:
Report Zeitraum: 20.02.2020 00:00:00 - 20.02.2020 23:59:59

Total E-mails gesendet : 9

Total E-mails empfangen: 5


Wird das dann auch über das Pattern geregelt, dass ich die o. a. Dinge als Array rausbekomme?
 
Nein. Der Pattern greifft nur die Tabelle ab, sofern sie vorhanden ist
Diese neue Struktur fällt da durch.
 
Zurück