Frage von PhilEs, 31

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

Folgende Situation: Ich bekomme jeden Tag eine Mail mit Preisupdates. Diese sind in einer Tabstopp-getrennten Textdatei (.txt), welche immer gleich aufgebaut ist.

Es reicht aber, diese einmal im Monat im Warenwirtschaftssystem einzuspielen.

Momentan sammle ich die Mails und nutze einmal im Monat einen VBA-Code (siehe unten), um gleichzeitig alle Anhänge mehrerer Mails in einen vorbestimmten Pfad zu speichern.

Als Ergebnis habe ich dann 30 oder 31 .txt-Dateien.

Mit einer .bat führe ich diese dann zusammen (copy *.txt Gesamtliste.txt) und importiere diese in Excel.

Meine Frage ist: Kann man den untenstehenden Code zum Speichern der Anhänge so erweitern, dass die einzelnen .txt-Dateien aus den Anhängen automatisch zusammengeführt und in Excel (z.B. als .csv-Datei) geöffnet werden?

Die Dateien haben keine Überschriften und sind von den Spaten her immer gleich aufgebaut.

Der Code steht aus Platzgründen in der ersten Antwort.

Antwort
von PhilEs, 26

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
von Ninombre, 20

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.

Keine passende Antwort gefunden?

Fragen Sie die Community