Sub email_Anhang_Sperr1_speichern()
Dim objOL As Object, objFolder As Object
Sheets("Doku").Select
Range("A100").Select
ActiveCell.FormulaR1C1 = "Titel"
ActiveCell.Offset(1, 0).Select
ActiveCell.FormulaR1C1 = "64_Sperr1_Parts - xls_daily_mail (QS)"
emailtitle = ActiveCell
On Error GoTo ErrExit
With Application
.ScreenUpdating = False
.EnableEvents = False
lngCalc = .Calculation
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
v_path1 = "S:\Quality\27_Temp\Crystal_Sperr_1_2_Reports"
v_path1 = IIf(Right(v_path1, 1) = "\", v_path1, v_path1 & "\")
Set objOL = CreateObject("Outlook.Application")
Set objFolder = objOL.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
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 Format(.ReceivedTime, "DD.MM.YYYY") = Format(Date, "DD.MM.YYYY") Then
If .Subject = emailtitle Then
lngRow = lngRow + 8
Cells(lngRow + 1, 1).Value = .Subject
Cells(lngRow + 2, 1).Value = .ReceivedTime
Cells(lngRow + 3, 1).Value = .SenderName
Cells(lngRow + 4, 1).Value = .SenderEmailAddress
Cells(lngRow + 5, 1).Value = .Body
Cells(lngRow + 6, 1).Value = .Attachments.Count
If .Attachments.Count > 0 Then
For lngIndex = 1 To .Attachments.Count
Debug.Print strPath & .Attachments.Item(lngIndex).Filename
.Attachments.Item(lngIndex).SaveAsFile v_path1 & .Attachments.Item(lngIndex).Filename
Next
End If
.UnRead = False
End If
End If
End With
Cells(lngRow + 2, 1).Offset(0, 1).Select
ActiveCell.FormulaR1C1 = "= DATE(YEAR(RC[-1]),MONTH(RC[-1]),DAY(RC[-1]))"
Cells(lngRow, 1).Select
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