Option Explicit
Sub email_Anhang_speichern_und_übergeben()
 
  Dim objOL As Object, objFolder As Object 'Es werden mehrere Objektinstanzen erzeugt
  '("late binding", die Objektinstanzen sind noch unspezifiziert)
  Dim strPath As String
  Dim lngIndex As Long, lngCur As Long, lngCount As Long, lngRow As Long
  Dim lngCalc As Long
  
  On Error GoTo ErrExit 'Hier werden Fehler durch eine eigene Prozedur abgefangen.
  
  With Application 'Das Makro läuft in Excel.
    .ScreenUpdating = False 'Indem der Bildschirm nicht andauernd aktualisiert wird, geht es schneller
    .EnableEvents = False
    lngCalc = .Calculation 'Hier wird eigtl nichts eingestellt, es wird nur eine Variable befüllt
    .Calculation = xlCalculationManual 'Da das Makro in Excel läuft, wird einfach auf manuelle Neuberechnung umgestellt.
    .DisplayAlerts = False
  End With
  
  strPath = "S:\Common\40_Werksentwicklung\04-KPI_QlikView\105_Sonderaufgaben_FHofmann\VBA\Outlook" 'In diesen Pfad soll der Anhang
  'gespeichert werden
  
  strPath = IIf(Right(strPath, 1) = "\", strPath, strPath & "\")
  
  Set objOL = CreateObject("Outlook.Application")
  Set objFolder = objOL.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
  
  lngCount = objFolder.Items.Count 'Das ist die Anzahl von emails im Posteingang
  
  lngRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row 'Hier wird einfach die erste freie Zelle in Spalte A gesucht
  
  For lngCur = 1 To lngCount 'Alle emails im ?Posteingang? werden durchlaufen
    Application.StatusBar = "Lese Posteingang " & _
      Format(lngCur / lngCount, "0%") 'In der Statuszeile wird einiges angezeigt
    With objFolder.Items(lngCur) 'Durch diese WITH-Schleife kann die Nennung des Objekts
    'bei den nächsten Befehlen entfallen
      If .Subject = "FX Rates *" Then
        lngRow = lngRow + 1
        Cells(lngRow, 1).Value = .Subject
        Cells(lngRow, 2).Value = .ReceivedTime
        Cells(lngRow, 3).Value = .SenderName
        Cells(lngRow, 4).Value = .SenderEmailAddress
        Cells(lngRow, 5).Value = .Body
        Cells(lngRow, 6).Value = .Attachments.Count
        If .Attachments.Count > 0 Then
          For lngIndex = 1 To .Attachments.Count
            Debug.Print strPath & .Attachments.Item(lngIndex).FileName 'Ausgabe im Direktfenster! (Strg+G)
            .Attachments.Item(lngIndex).SaveAsFile strPath & .Attachments.Item(lngIndex).FileName
          Next
        End If
        .UnRead = False 'als gelesen markieren
        '.Delete 'Löschen
      End If
    End With
  Next
  
  [A2].Select
  ActiveWorkbook.Saved = True
  
ErrExit:
  
  With Err
    If .Number <> 0 Then
      MsgBox "Fehler in Prozedur:" & vbTab & "'OutlookPosteingang'" & vbLf & String(60, "_") & _
        vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
        "Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
        .Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _
        "VBA - Fehler in Modul - Modul1"
      .Clear
    End If
  End With
  
  On Error GoTo 0
  
  With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = lngCalc
    .DisplayAlerts = True
    .StatusBar = False
  End With
  
  Set objFolder = Nothing
  Set objOL = Nothing
 
End Sub