MS Outlook2010: Alle Anhänge mehrerer Mails per VBA-Code speichern, zusammenführen und in Excel öffnen?

...komplette Frage anzeigen

2 Antworten

Was genau möchtest Du vom Handling her verbessern?

Entfällt die Notwendigkeit die TXT Dateien in einem Ordner zu speichern, wenn man sie direkt in Excel importieren könnte?

Die Fragen einfach vor dem Hintergrund, dass ich unschlüssig bin, ob man eher den Export aus Outlook optimiert oder den Import nach Excel. Den eigenen Batch zum Zusammenführen könnte man weglassen, wenn der stört.

Antwort bewerten Vielen Dank für Deine Bewertung

Hier der Code:


Sub Anlagen_speichern()


'HIER DEN PFAD ÄNDERN ! ! !
Const fcPath As String = "I:\\\\Stammdaten\\\\Preisupdates"

Dim olExplorer As Explorer
Dim olFolder As MAPIFolder
Dim olSelection As Selection
Dim olitem As MailItem
Dim lngAttCount As Long
Dim i As Long
Dim Anzahl As Long
Dim fcZahl As Integer
Dim fcName As String
Dim fcEndung As String
Dim dateiname As String

Set olExplorer = Application.ActiveExplorer
Set olFolder = Application.ActiveExplorer.CurrentFolder
Anzahl = 0

If Dir(fcPath, vbDirectory) <> "" Then
If olFolder.DefaultItemType = olMailItem Then
Set olSelection = olExplorer.Selection

'Für jede Email die Makiert ist
For Each olitem In olSelection
lngAttCount = olitem.Attachments.Count

'Falls es anhänge gibt
If lngAttCount > 0 Then

'Für jeden Anhang
For i = lngAttCount To 1 Step -1

With olitem.Attachments.Item(i)

'Falls Datei schon existiert einfach zahl hinter hängen
If CreateObject("Scripting.FileSystemObject").FileExists(fcPath & "\\\\" & .FileName) Then
'Datei existiert schon -> Zahl hochzählen bis noch nicht existiert
fcZahl = 2
fcName = CreateObject("Scripting.FileSystemObject").GetBaseName(fcPath & "\\\\" & .FileName)
fcEndung = CreateObject("Scripting.FileSystemObject").GetExtensionName(fcPath & "\\\\" & .FileName)
While CreateObject("Scripting.FileSystemObject").FileExists(fcPath & "\\\\" & fcName & "(" & CStr(fcZahl) & ")." & fcEndung)
fcZahl = fcZahl + 1
Wend
dateiname = fcName & "(" & CStr(fcZahl) & ")." & fcEndung
Else
'Datei existiert noch nicht
dateiname = .FileName
End If

'Datei speichern
.SaveAsFile fcPath & "\\\\" & dateiname

End With
Anzahl = Anzahl + 1
Next i

End If

Next olitem

Else
MsgBox "In diesem Ordner befinden sich keine E-Mail-Nachrichten."
End If
If Anzahl < 1 Then
MsgBox "Keine Anlagen vorhanden"
Else
If Anzahl < 2 Then
MsgBox Anzahl & " Anlage gespeichert"
Else
MsgBox Anzahl & " Anlagen gespeichert"
End If
End If
Else
MsgBox "Der im Makro zum speichern der Anhänge eingetragene Pfad ""fcPath"" existiert nicht!"
End If

End Sub

Antwort bewerten Vielen Dank für Deine Bewertung

Was möchtest Du wissen?