Outlook EMail Anhang speichern

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Sub OutlookPosteingang() Dim OLF As Outlook.MAPIFolder Dim AnzEintraege As Integer, i As Integer, Email As Integer On Error Resume Next Set OLF = GetObject("", "Outlook.Application") _ .GetNamespace("MAPI").GetDefaultFolder(olFolderInbox) AnzEintraege = OLF.Items.Count i = 0: Email = 0 While i

Sub OutlookPosteingang() Dim objOL As Object, objFolder As Object Dim strPath As String Dim lngIndex As Long, lngCur As Long, lngCount As Long, lngRow As Long On Error Resume Next strPath = "E:\Temp" 'Speicherpfad - Anpassen! strPath = IIf(Right(strPath, 1) = "\", strPath, strPath & "\") Set objOL = CreateObject("Outlook.Application") Set objFolder = objOL.GetNamespace("MAPI").GetDefaultFolder(6) lngCount = objFolder.Items.Count lngRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row For lngCur = 1 To lngCount Application.StatusBar = "Lese Posteingang " & _ Format(lngCur / lngCount, "0%") With objFolder.Items(lngCur) If .Subject = "test" 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 .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 Application.StatusBar = False Set objFolder = Nothing Set objOL = Nothing End Sub

Hallo Jens,
Fehlermeldung kann keine kommen, weil du ja "On Error Resume Next" drin stehen hast.
Jetzt weißt du, warum man das nur in Ausnahmefällen verwenden soll!
Teste mal so und schau, was im Direktfenster ausgegeben wird.

Sub OutlookPosteingang()
  Dim objOL As Object, objFolder As Object
  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
  
  With Application
    .ScreenUpdating = False
    .EnableEvents = False
    lngCalc = .Calculation
    .Calculation = xlCalculationManual
    .DisplayAlerts = False
  End With
  
  strPath = "E:\Temp" 'Speicherpfad - Anpassen!
  
  strPath = IIf(Right(strPath, 1) = "\", strPath, strPath & "\")
  
  Set objOL = CreateObject("Outlook.Application")
  Set objFolder = objOL.GetNamespace("MAPI").GetDefaultFolder(6)
  
  lngCount = objFolder.Items.Count
  
  lngRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
  
  For lngCur = 1 To lngCount
    Application.StatusBar = "Lese Posteingang " & _
      Format(lngCur / lngCount, "0%")
    With objFolder.Items(lngCur)
      If .Subject = "test" 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

« Gruß Sepp »

Beliebteste Forumthreads (12 Monate)

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

48 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Outlook EMail Anhang speichern

10 Beiträge zum Forumthread Beiträge zu diesem Forumthread

48 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread