Outlook-Workshop -Email auslesen - Teil 2

Angelehnt an "Inhalt einer Email auslesen - Teil 1 ". Hier gehen wir ein bisschen weiter. Ausgelesen werden Absender, Absender-Emailadresse und das Sendedatum. In diesem Beispiel werden alle Konten ausgelesen. Für jedes Konto wird automatisch eine Tabelle angelegt, welche den Namen des Kontos erhält. Dies geschieht bereits beim Starten der Userform, sofern für das Konto noch kein Tabellenblatt existiert. Der Aufbau des Tabellenblattes entspricht dem Aufbau aus dem vorangegangen Teil, ohne die Spalte "Anhänge".


Zuerst eine Userform erstellen. Für das Beispiel benötigen wir vier Kombinationsfelder (ComboBox), 4 Bezeichnungsfelder (Label) und 4 Schaltflächen. Die farbigen Label zwischendrin dienen nur der optischen Trennung der einzelnen Auswahlfelder.




Der Code für den Dialog:

Option Explicit

'  ' 

Rem Outlook-Objekte 
Dim olapp         As Outlook.Application
Dim olName        As Outlook.Namespace
Dim olFolder      As Outlook.MAPIFolder

Rem Objekte 
Dim olAcCount     As Object

Rem Zähler 
Dim olItemsCount  As Long
Dim letzteZeile   As Long

'  ' 

'  ' 
Private Sub ComboBox1_Change()

ComboBox2.Clear

    With ComboBox2
    
       For Each olAcCount In olapp.Session.Folders(ComboBox1.Text).Folders
          Select Case olAcCount.Name
                 Case "Posteingang", "Inbox", "Postausgang", "Outbox", "Gelöschte Elemente", _
                      "Entwürfe", "Gesendete Elemente", "Junk-E-Mail", "Phishing-E-Mail"

                      .AddItem olAcCount.Name
                 Case Else
                      
                 End Select
       Next olAcCount
       
       .ListIndex = 1
       
    End With
    
Label2.Caption = "Ordner in " & ComboBox1.Text

Sheets(ComboBox1.Text).Activate

End Sub
'  ' 

'  ' 
Private Sub ComboBox2_Change()

ComboBox3.Clear

On Error Resume Next

    With ComboBox3
    
       For Each olAcCount In olapp.Session.Folders(ComboBox1.Text).Folders(ComboBox2.Text).Folders
                 .AddItem olAcCount.Name
       Next olAcCount
       
       .ListIndex = 0
       
    End With
    
  Label3.Caption = "Ordner in " & ComboBox1.Text & vbCrLf & "-> " & ComboBox2.Text
  
End Sub

Private Sub CommandButton1_Click()

On Error Resume Next

Set olFolder = olName.Session.Folders(ComboBox1.Text).Folders(ComboBox2.Text)

letzteZeile = Sheets(ComboBox1.Text).Range("A" & Rows.Count).End(xlUp).Row

   For olItemsCount = 1 To olFolder.Items.Count
       With olFolder.Items.Item(olItemsCount)
                 Sheets(ComboBox1.Text).Range("A" & olItemsCount + letzteZeile).Value = ComboBox1.Text & "->" & ComboBox2.Text & "->" & ComboBox3.Text
                 Sheets(ComboBox1.Text).Range("B" & olItemsCount + letzteZeile).Value = .Sender
                 Sheets(ComboBox1.Text).Range("C" & olItemsCount + letzteZeile).Value = .SenderEmailAddress
                 Sheets(ComboBox1.Text).Range("D" & olItemsCount + letzteZeile).Value = .ReceivedTime
                 Sheets(ComboBox1.Text).Range("E" & olItemsCount + letzteZeile).Value = .Subject
       End With
   Next olItemsCount
   
End Sub
'  ' 

'  ' 
Private Sub ComboBox3_Change()

ComboBox4.Clear

On Error Resume Next

    With ComboBox4
    
       For Each olAcCount In olapp.Session.Folders(ComboBox1.Text).Folders(ComboBox2.Text).Folders(ComboBox3.Text).Folders
                 .AddItem olAcCount.Name
       Next olAcCount
       
       .ListIndex = 0
       
    End With
    
    Label4.Caption = "Ordner in " & ComboBox1.Text & vbCrLf & "-> " & ComboBox2.Text & vbCrLf & "-> " & ComboBox3.Text
    
End Sub


Private Sub CommandButton2_Click()

On Error Resume Next


Set olFolder = olName.Session.Folders(ComboBox1.Text).Folders(ComboBox3.Text).Folders(ComboBox4.Text)

letzteZeile = Sheets(ComboBox1.Text).Range("A" & Rows.Count).End(xlUp).Row

   For olItemsCount = 1 To olFolder.Items.Count
       With olFolder.Items.Item(olItemsCount)
                 Sheets(ComboBox1.Text).Range("A" & olItemsCount + letzteZeile).Value = ComboBox1.Text & "->" & ComboBox2.Text & "->" & ComboBox3.Text
                 Sheets(ComboBox1.Text).Range("B" & olItemsCount + letzteZeile).Value = .Sender
                 Sheets(ComboBox1.Text).Range("C" & olItemsCount + letzteZeile).Value = .SenderEmailAddress
                 Sheets(ComboBox1.Text).Range("D" & olItemsCount + letzteZeile).Value = .ReceivedTime
                 Sheets(ComboBox1.Text).Range("E" & olItemsCount + letzteZeile).Value = .Subject
       End With
   Next olItemsCount
   
End Sub
'  ' 

'  ' 
Private Sub ComboBox4_Change()

End Sub

Private Sub CommandButton3_Click()
On Error Resume Next


Set olFolder = olName.Session.Folders(ComboBox1.Text).Folders(ComboBox2.Text).Folders(ComboBox3.Text).Folders(ComboBox4.Text)

letzteZeile = Sheets(ComboBox1.Text).Range("A" & Rows.Count).End(xlUp).Row

   For olItemsCount = 1 To olFolder.Items.Count
       With olFolder.Items.Item(olItemsCount)
                 Sheets(ComboBox1.Text).Range("A" & olItemsCount + letzteZeile).Value = ComboBox1.Text & "->" & ComboBox2.Text & "->" & ComboBox3.Text & "->" & ComboBox4.Text
                 Sheets(ComboBox1.Text).Range("B" & olItemsCount + letzteZeile).Value = .Sender
                 Sheets(ComboBox1.Text).Range("C" & olItemsCount + letzteZeile).Value = .SenderEmailAddress
                 Sheets(ComboBox1.Text).Range("D" & olItemsCount + letzteZeile).Value = .ReceivedTime
                 Sheets(ComboBox1.Text).Range("E" & olItemsCount + letzteZeile).Value = .Subject
       End With
   Next olItemsCount
   
End Sub
'  ' 



'  ' 
Private Sub CommandButton4_Click()
   Set olName = Nothing
   Set olapp = Nothing

   Unload Me
   
End Sub

Private Sub UserForm_Initialize()

Dim myWsh As Worksheet
Dim xlSCount As Long
    
Set olapp = New Outlook.Application
Set olName = olapp.GetNamespace("MAPI")

Application.ScreenUpdating = False

    With ComboBox1
         For Each olAcCount In olapp.Session.Accounts
                 .AddItem olAcCount.DisplayName
                 On Error Resume Next
                 xlSCount = Sheets.Count
                 Set myWsh = Worksheets(olAcCount.DisplayName)
                     If Err.Number <> 0 Then
                        Sheets("Master").Visible = True
                        Sheets("Master").Copy After:=Sheets(xlSCount)
                        Worksheets(xlSCount + 1).Name = olAcCount.DisplayName
                        Sheets("Master").Visible = False
                     End If
                 On Error GoTo 0
         Next olAcCount
         
         .ListIndex = 0
    End With

Application.ScreenUpdating = True
End Sub
'  '

Eine Beispieldatei (XLSB. Als ZIP-Archiv): Read Outlook-MailItems