Hallo,
den Code hab ich online gefunden, aber ich hab den Link nicht mehr. Hier ist der Code, den ich aktuell verwende:
Sub email_Anhang_Sperr1_speichern()
'Author: Friedrich Hofmann
'Erstelldatum: 16.11.2015
'Zweck: Mehrere email-Anhänge (Infos zu den Sperrflächen) sollen aus Outlook heraus gespeichert und
'im Anschluss bearbeitet werden.
'--------------------------------------------------------------------------
'ACHTUNG: Das Funktionieren dieses Codes setzt voraus, dass im VB-Editor
'im Menü "Tools->References" die "MS Outlook nn Objektbibliothek" referenziert
'wird (einfach die Checkbox anhaken)
'---------------------------------------------------------------------------
Dim objOL As Object, objFolder As Object 'Es werden mehrere Objektinstanzen erzeugt
'("late binding", die Objektinstanzen sind noch unspezifiziert)
'Das Workbook ist ohnehin schon offen.
'Wir müssen nur das richtige Sheet auswählen.
Sheets("Doku").Select
Range("A100").Select 'Wir müssen einen Bereich auswählen, wo sicherlich nichts mehr steht.
ActiveCell.FormulaR1C1 = "Titel"
ActiveCell.Offset(1, 0).Select
ActiveCell.FormulaR1C1 = "64_Sperr1_Parts - xls_daily_mail (QS)"
'64_Sperr1_Parts - xls_daily_mail (QS)
emailtitle = ActiveCell
'MsgBox emailtitle
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
'In diesen Pfad soll der Anhang gespeichert werden
'----------------------------------------------------------------------------------
'ACHTUNG: Diese Variable wird in der Prozedur für Sperr2 noch einmal definiert, sie muss aber
'genau dieselbe sein. Wenn sich was ändert, muss man also darauf aufpassen!
'----------------------------------------------------------------------------------
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")
' Die Konstante olFolderInbox entspr. wohl der Nr. 6
Set objFolder = objOL.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
lngCount = objFolder.Items.Count 'Das ist die Anzahl von emails im Posteingang
' MsgBox lngCount
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
'In dem Postfach liegen mglw ziemlich viele Alt-emails rum, wir wollen nur die eine, die mit dem
'bekannten Betreff am aktuellen Tag gekommen ist.
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 'Ausgabe im Direktfenster! (Strg+G)
.Attachments.Item(lngIndex).SaveAsFile v_path1 & .Attachments.Item(lngIndex).Filename
Next
End If
.UnRead = False 'als gelesen markieren
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 'Jetzt müssen wir nur schnell wieder zurückspringen, damit da nichts schiefgehen kann.
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
Wie man sehen kann, verwendet dieser Code die Konstante olFolderInbox - die Inhalte der gesuchten email (anhand der Betreffzeile identifiziert) werden in die aktive Excel-Datei geschrieben, die Anhänge runtergeladen und in der Folge weiterverarbeitet.
Gruß,
Officer_Bierschnitt
|