E-mails aus Outlook2000 als Textdatei ablegen

Nachfolgender Tipp zeigt, wie sich aus einem bestimmten Outlook-Mailordner alle Mails in einen eigenen Ordner der Festplatte speichern lassen. Hierbei werden evtl. vorhandene Anlagen autom. als Dateien gespeichert.

Für das Beispiel wird eine Form mit einem CommandButton benötigt.

Option Explicit

Private Sub Command1_Click()
\‘ Mails und Anlagen in den Ordner
\‘ c:\\test speichern. Falls der Ordner nicht existiert,
\‘ wird dieser autom. erstellt.
Email_To_HDD \“c:\\test\“
End Sub
Public Sub Email_To_HDD(ByVal sPath As String)
Dim oOutlook As Object \‘ Outlook Object
Dim oNamespace As Object \‘ Namespace Object
Dim oFolder As Object \‘ MapiFolder Object
Dim oMail As Object \‘ Mail Object
Dim oAnhang As Object \‘ Attachment Object
Dim i As Integer
Dim j As Integer

\‘ Outlook-Konstanten
Const olFolderInbox = 6
Const olTXT = 0

\‘ Ggf. abschließenden Backslash entfernen
If Right$(sPath, 1) = \“\\\“ Then
sPath = Left$(sPath, Len(sPath) – 1)
End If

\‘ Falls Zielordner nicht existiert,
\‘ jetzt erstellen
If Dir$(sPath, vbDirectory + vbHidden) = \“\“ Then
MkDir sPath
End If

\‘ Outlook-Objekt erstellen
Set oOutlook = CreateObject(\“Outlook.Application\“)

\‘ Namespace: MAPI
Set oNamespace = oOutlook.GetNamespace(\“MAPI\“)

\‘ Outlook-Ordner: \“Neue Nachrichten\“
Set oFolder = oNamespace.GetDefaultFolder(olFolderInbox)

\‘ Alle Mails durchlaufen
i = 1
j = oFolder.Items.Count
Do While j > 0
Set oMail = oFolder.Items(j)

\‘ Auf Anhang prüfen und evtl. speichern
With oMail.Attachments
i = .Count
Do While (i > 0)
Set oAnhang = .Item(i)

\‘ Anhang unter entsprechendem Namen speichern.
\‘ Das \“i_\“ ist nur zur Sicherheit, um doppelte
\‘ Dateinamen zu verhindern
oAnhang.SaveAsFile sPath & \“\\\“ & CStr(i) & \“_\“ & _
oAnhang.DisplayName
i = i – 1
Loop
End With

\‘ Nachricht speichern
oMail.SaveAs sPath & CStr(i) & \“_\“ & _
oMail.Subject & \“.txt\“, olTXT
j = j – 1
Loop

\‘ Fertig
MsgBox \“Done\“

\‘ Objekte zerstören
Set oMail = Nothing
Set oAnhang = Nothing
Set oFolder = Nothing
Set oNamespace = Nothing
Set oOutlook = Nothing
End Sub

E.Lappen 🙂