Outlook war tot. Wie kann ich meine E-Mails selbst sichern?

Von /

Donnerstagabend, kurz vor sieben. Outlook verbindet sich nicht mehr. Teams auch nicht. Am Freitagmorgen kommt dann die Frage, die mit dem Ausfall selbst wenig zu tun hat und trotzdem die wichtigste ist: „Wenn das nicht wiederkommt, haben wir unsere E-Mails dann eigentlich noch?“ Wer seine E-Mails selbst sichern will, braucht dafür kein neues Abo. Microsoft Access, ein paar Zeilen VBA und eine externe Festplatte reichen.

Bei mir lief Outlook am Freitagnachmittag wieder. Meine erste Amtshandlung danach war kein Kaffee, sondern ein Backup.

Was am 12. und 13. November passiert ist

Ab Donnerstagabend, kurz vor 19 Uhr, waren Outlook, Teams, OneDrive und weitere Dienste aus Microsoft 365 weltweit gestört. Microsoft sprach von einer Überlastung der Infrastruktur in vielen Regionen. Auf Downdetector liefen gegen 19 Uhr knapp 130.000 Störungsmeldungen allein zu Outlook auf. Nach Microsofts Angaben gab es keine Hinweise auf einen Angriff. Bis in den Freitag hinein blieb die Lage instabil.

Es war nicht der erste Ausfall in diesem Jahr. Schon Ende August waren Microsofts E-Mail-Dienste stundenlang nicht erreichbar.

Ein Ausfall ist noch kein Datenverlust. Aber er zeigt dir sehr zuverlässig, ob du ohne deinen Anbieter an deine eigenen Daten kommst.

Microsoft sichert deine E-Mails nicht

Microsoft betreibt eine hochverfügbare Cloud. Fällt ein Rechenzentrum aus, springt ein anderes ein. Das ist Redundanz, kein Backup. Im sogenannten Shared Responsibility Model ist die Aufteilung klar geregelt: Microsoft ist für die Verfügbarkeit der Dienste zuständig, du für deine Daten. Ausführlich habe ich das im Beitrag Microsoft sichert deine M365-Daten nicht beschrieben.

Microsoft sagt das übrigens selbst. Im Microsoft-Servicevertrag steht sinngemäß, dass du bei einem Ausfall möglicherweise nicht an deine gespeicherten Inhalte kommst. Direkt danach folgt die Empfehlung, deine Daten regelmäßig zu sichern.

Ein Backup ist eine Kopie deiner Daten, die unabhängig vom Original erreichbar ist. Ein Papierkorb mit 14 bis 93 Tagen Aufbewahrungsfrist ist keins.

Und das kostenpflichtige Microsoft 365 Backup?

Seit Juli 2024 bietet Microsoft mit „Microsoft 365 Backup“ tatsächlich eine eigene Sicherung an. Sie ist nicht im normalen Abo enthalten, sondern wird nach Datenmenge abgerechnet: Listenpreis 0,15 US-Dollar pro Gigabyte und Monat. Die Sicherungen liegen innerhalb von Microsofts eigener Cloud, in den Rechenzentren der jeweiligen Region.

Das ist praktisch, wenn jemand versehentlich einen Ordner löscht oder ein Postfach verschlüsselt wird. Bei einem Ausfall wie diesem hilft es dir wenig. Das Backup wohnt im selben Haus wie das Original. Wenn Microsoft den Zugang zu Outlook nicht hinbekommt, ist nicht garantiert, dass du in dem Moment an die Sicherung kommst.

Ein Backup beim selben Anbieter schützt dich vor deinen eigenen Fehlern. Vor den Fehlern des Anbieters schützt es dich nicht.

Outlook-E-Mails sichern mit Access: so sieht das aus

Die pragmatische Variante läuft auf dem Rechner, auf dem Outlook sowieso installiert ist. Eine kleine Access-Datenbank steuert Outlook fern und macht Folgendes:

  1. Sie fragt einmal nach dem Zielordner, zum Beispiel einer externen Festplatte oder einem Ordner auf dem NAS.
  2. Sie geht jedes eingebundene Postfach und jeden Mail-Ordner durch.
  3. Sie speichert jede E-Mail als eigene .msg-Datei, benannt nach Schema „Datum Absendername ‹absender@firma.de› Betreff“.
  4. Sie spiegelt die Ordnerstruktur aus Outlook auf der Festplatte: Postfach, Posteingang, Unterordner.
  5. Sie merkt sich in einer Tabelle, welche Mails schon gesichert sind. Beim nächsten Lauf kommen nur die neuen dazu.

Den wöchentlichen Lauf übernimmt die Windows-Aufgabenplanung. Access startet, sichert, schließt sich wieder. Eine Zusatzbibliothek wie Redemption ist dafür nicht nötig.

Warum .msg? Weil sich jede Datei per Doppelklick öffnen lässt, mit allen Anhängen. Und weil du sie per Drag-and-drop wieder in Outlook ziehen kannst. Die eckigen Klammern um die Mailadresse sind übrigens keine Spielerei: Die Zeichen < und > sind in Windows-Dateinamen verboten, ‹ und › nicht.

Bei mir waren das 12 Postfächer mit zusammen über 40.000 E-Mails. Der erste Lauf hat 45 Minuten gedauert und 7 GB auf der Platte belegt. Der wöchentliche Lauf danach braucht deutlich weniger Zeit.

Ein angenehmer Nebeneffekt: Die Sicherung arbeitet mit dem lokalen Zwischenspeicher von Outlook. Was Outlook bereits heruntergeladen hat, lässt sich auch dann sichern, wenn Microsofts Server gerade nicht antworten.

Warum nicht einfach eine PST-Datei exportieren?

Naheliegend wäre der Export über das Outlook-Menü in eine PST-Datei. Den habe ich bewusst nicht gewählt. Eine PST ist eine einzige große Datei, schnell mehrere Gigabyte schwer. Ist sie beschädigt, ist alles weg. Sie wächst bei jedem Export komplett neu, statt nur die neuen Mails aufzunehmen. Und ohne Outlook kommst du nicht hinein.

Einzelne .msg-Dateien in einer sauberen Ordnerstruktur kannst du mit dem Windows-Explorer durchsuchen. Eine defekte Datei betrifft genau eine E-Mail. Und die Access-Tabelle dahinter ist gleichzeitig dein Protokoll: Wann wurde was gesichert, wohin, wie viele pro Lauf.

Ein Backup, das du ohne die Software des Herstellers nicht lesen kannst, ist nur ein halbes Backup.

Wo dieser Ansatz an Grenzen stößt

Damit kein falscher Eindruck entsteht, die Einschränkungen gehören dazu:

  • Nur das klassische Outlook. Das „neue Outlook“ bietet keine Schnittstelle für Fernsteuerung. Microsoft drängt die Anwender gerade dorthin. Diese Sicherung hat also ein Haltbarkeitsdatum, wenn auch kein kurzes.
  • Nur E-Mails. Kalender, Kontakte, Teams-Chats und OneDrive-Dateien sichert sie nicht.
  • Nur, was lokal ist. Online-Archive, die Outlook nicht zwischenspeichert, bleiben außen vor.
  • Sicherheitsabfrage. Erkennt Outlook keinen aktuellen Virenschutz, fragt es bei jedem Zugriff nach. Das lässt sich im Trust Center prüfen.
  • Kein revisionssicheres Archiv. Ein Ordner voller .msg-Dateien erfüllt nicht die Anforderungen an eine unveränderbare E-Mail-Archivierung nach GoBD. Für steuerrelevante Korrespondenz brauchst du zusätzlich ein echtes Archivsystem.
  • Eine Kopie ist noch keine Strategie. Hängt die Festplatte dauerhaft am Rechner, verschlüsselt Ransomware sie gleich mit. Die 3-2-1-Regel gilt auch hier: drei Kopien, zwei Medien, eine außer Haus.

Was das für dich als Geschäftsführer bedeutet

Du musst diesen Code nicht verstehen. Aber stell deiner IT nach diesem Wochenende eine einzige Frage: „Wenn Microsoft drei Tage weg ist, wie komme ich an die Mail mit dem Angebot vom letzten Dienstag?“

Lautet die Antwort „gar nicht“, hast du kein technisches Problem, sondern ein betriebliches. Dann hängt dein Vertrieb, deine Auftragsannahme und im Zweifel deine Nachweispflicht an der Verfügbarkeit eines einzigen Anbieters. Eine lokale Kopie der E-Mails ist kein Ersatz für ein durchdachtes Backup-Konzept. Sie ist aber ein schneller erster Schritt, der kein Abo kostet und mit Werkzeugen läuft, die in den meisten Betrieben ohnehin vorhanden sind.

Für die Technik: der Code

Das Werkzeug besteht aus einer Access-Datenbank mit vier Tabellen und einem VBA-Modul. Es arbeitet mit dem klassischen Outlook per Late Binding, also ohne Verweis auf die Outlook-Bibliothek und ohne Zusatzkomponenten wie Redemption.

Option Compare Database
Option Explicit

'==============================================================================
' modMailBackup
' Sichert alle Outlook-Postfächer als .msg (klassisches Outlook, Late Binding,
' ohne Redemption). Einstiege:
'   DatenmodellAnlegen  - legt Tabellen an bzw. ergänzt/migriert sie
'   KomplettStart       - Zielpfad wählen, alle Ordner vollständig durchgehen
'   FolgeStart          - letzter Zielpfad, nur Mails seit letztem OK-Lauf
'   FolgeStartAuto      - Wrapper für Makro /x (AusführenCode braucht Function)
'==============================================================================

'--- Outlook-Konstanten
Private Const olMSGUnicode As Long = 9
Private Const olMail As Long = 43
Private Const olMailItem As Long = 0
Private Const PR_SENDER_SMTP As String = "http://schemas.microsoft.com/mapi/proptag/0x5D01001F"
Private Const PR_MSG_ID As String = "http://schemas.microsoft.com/mapi/proptag/0x1035001F"

'--- Steuerung
Private Const MAX_FEHLER As Long = 200          ' danach Abbruch (z. B. Platte voll)
Private Const UEBERLAPPUNG_TAGE As Long = 1      ' Sicherheitsabstand beim Folgelauf

'--- Laufzeitstatus
Private mdb As DAO.Database
Private mrsLog As DAO.Recordset
Private mrsFehler As DAO.Recordset
Private mfso As Object
Private mlngLauf As Long
Private mlngAnzahl As Long
Private mlngFehler As Long
Private mbAbbruch As Boolean
Private mstrStore As String
Private mstrOrdner As String


'==============================================================================
' 1) Datenmodell
'==============================================================================
Public Sub DatenmodellAnlegen(Optional ByVal bStill As Boolean = False)
    Dim db As DAO.Database
    On Error GoTo Fehler
    Set db = CurrentDb

    '--- Gesicherte Mails (Schlüssel = Internet-Message-ID bzw. EntryID)
    If Not TabelleExistiert(db, "tblMailBackup") Then
        db.Execute "CREATE TABLE tblMailBackup (" & _
                   "MsgKey TEXT(255) CONSTRAINT PrimaryKey PRIMARY KEY, " & _
                   "Pfad MEMO, Gesichert DATETIME, LaufID LONG)", dbFailOnError
    Else
        FeldErgaenzen db, "tblMailBackup", "LaufID", "LONG"
    End If

    '--- Läufe
    If Not TabelleExistiert(db, "tblBackupLauf") Then
        db.Execute "CREATE TABLE tblBackupLauf (" & _
                   "LaufID COUNTER CONSTRAINT PrimaryKey PRIMARY KEY, " & _
                   "Modus TEXT(20), Start DATETIME, Ende DATETIME, Ziel TEXT(255), " & _
                   "Anzahl LONG, Fehler LONG, Status TEXT(20))", dbFailOnError
    Else
        FeldErgaenzen db, "tblBackupLauf", "Modus", "TEXT(20)"
        FeldErgaenzen db, "tblBackupLauf", "Fehler", "LONG"
        If FeldErgaenzen(db, "tblBackupLauf", "Status", "TEXT(20)") Then
            ' Migration aus Version 1: Erfolg (Ja/Nein) -> Status
            If FeldExistiert(db, "tblBackupLauf", "Erfolg") Then
                db.Execute "UPDATE tblBackupLauf SET Status = IIf(Erfolg, 'OK', 'Abgebrochen') " & _
                           "WHERE Status Is Null", dbFailOnError
            End If
        End If
    End If

    '--- Fehlerprotokoll
    If Not TabelleExistiert(db, "tblBackupFehler") Then
        db.Execute "CREATE TABLE tblBackupFehler (" & _
                   "FehlerID COUNTER CONSTRAINT PrimaryKey PRIMARY KEY, " & _
                   "LaufID LONG, Zeitpunkt DATETIME, Prozedur TEXT(64), " & _
                   "FehlerNr LONG, FehlerText MEMO, Store TEXT(255), Ordner MEMO, " & _
                   "Betreff TEXT(255), MsgKey TEXT(255), Datei MEMO)", dbFailOnError
        db.Execute "CREATE INDEX idxFehlerLauf ON tblBackupFehler (LaufID)", dbFailOnError
    End If

    '--- Ausgeschlossene Stores (z. B. Online-Archiv, Öffentliche Ordner)
    If Not TabelleExistiert(db, "tblStoreAusschluss") Then
        db.Execute "CREATE TABLE tblStoreAusschluss (" & _
                   "StoreName TEXT(255) CONSTRAINT PrimaryKey PRIMARY KEY)", dbFailOnError
    End If

    db.TableDefs.Refresh
    Exit Sub

Fehler:
    Debug.Print Now, "DatenmodellAnlegen", Err.Number, Err.Description
    If Not bStill Then MsgBox "Datenmodell konnte nicht angelegt werden:" & vbCrLf & _
                              Err.Number & " - " & Err.Description, vbCritical, "Mail-Backup"
End Sub


'==============================================================================
' 2) Komplettlauf: Zielpfad abfragen, alles durchgehen (Duplikate werden übersprungen)
'==============================================================================
Public Sub KomplettStart()
    Dim strZiel As String

    DatenmodellAnlegen
    strZiel = ZielpfadWaehlen(LetzterZielpfad())
    If Len(strZiel) = 0 Then Exit Sub

    BackupAusfuehren strZiel, "Komplett", 0, False
End Sub


'==============================================================================
' 3) Folgelauf: letzter Zielpfad, nur Mails seit letztem OK-Lauf (minus Überlappung)
'==============================================================================
Public Sub FolgeStart(Optional ByVal bStill As Boolean = False)
    Dim strZiel As String, dtAb As Date

    DatenmodellAnlegen bStill
    strZiel = LetzterZielpfad()

    If Len(strZiel) = 0 Then
        If bStill Then
            ' kein Dialog möglich: Lauf wird als abgebrochen protokolliert
            BackupAusfuehren "", "Folge", 0, True
            Exit Sub
        End If
        strZiel = ZielpfadWaehlen("")
        If Len(strZiel) = 0 Then Exit Sub
    End If

    dtAb = Nz(DMax("Start", "tblBackupLauf", "Status='OK'"), 0)
    If dtAb > 0 Then dtAb = dtAb - UEBERLAPPUNG_TAGE   ' 0 = wirkt wie Komplettlauf

    BackupAusfuehren strZiel, "Folge", dtAb, bStill
End Sub

'--- Für die Aufgabenplanung: Makro mcrMailBackup -> AusführenCode FolgeStartAuto() -> Beenden
Public Function FolgeStartAuto() As Boolean
    FolgeStart True
    FolgeStartAuto = True
End Function


'==============================================================================
' Kern
'==============================================================================
Private Sub BackupAusfuehren(ByVal strZiel As String, ByVal strModus As String, _
                             ByVal dtAb As Date, ByVal bStill As Boolean)
    Dim olApp As Object, ns As Object, st As Object
    Dim strStatus As String

    On Error GoTo Fehler
    Set mdb = CurrentDb
    Set mfso = CreateObject("Scripting.FileSystemObject")
    mlngLauf = 0: mlngAnzahl = 0: mlngFehler = 0: mbAbbruch = False
    mstrStore = "": mstrOrdner = ""

    mlngLauf = LaufAnlegen(strModus, strZiel)
    Set mrsFehler = mdb.OpenRecordset("tblBackupFehler", dbOpenDynaset, dbAppendOnly)
    Set mrsLog = mdb.OpenRecordset("tblMailBackup", dbOpenTable)
    mrsLog.Index = "PrimaryKey"

    If Len(strZiel) = 0 Then _
        Err.Raise vbObjectError + 1000, , "Kein Zielpfad hinterlegt. Bitte einmal KomplettStart ausführen."
    If Not mfso.FolderExists(strZiel) Then _
        Err.Raise vbObjectError + 1001, , "Zielpfad nicht erreichbar (Laufwerk getrennt?): " & strZiel

    Set olApp = OutlookHolen()
    If olApp Is Nothing Then _
        Err.Raise vbObjectError + 1002, , "Outlook nicht verfügbar. Klassisches Outlook installiert und Profil angemeldet?"
    Set ns = olApp.GetNamespace("MAPI")

    For Each st In ns.Stores
        If mbAbbruch Then Exit For
        StoreSichern st, strZiel, dtAb
    Next

    If mbAbbruch Then
        FehlerLog "BackupAusfuehren", 0, "Abbruch nach " & MAX_FEHLER & " Fehlern."
        strStatus = "Abgebrochen"
    ElseIf mlngFehler > 0 Then
        strStatus = "Mit Fehlern"
    Else
        strStatus = "OK"
    End If

Abschluss:
    On Error Resume Next
    LaufAbschliessen strStatus
    If Not bStill Then
        MsgBox "Lauf " & mlngLauf & " (" & strModus & "): " & strStatus & vbCrLf & _
               mlngAnzahl & " Mails gesichert, " & mlngFehler & " Fehler." & _
               IIf(mlngFehler > 0, vbCrLf & "Details in tblBackupFehler.", ""), _
               IIf(strStatus = "OK", vbInformation, vbExclamation), "Mail-Backup"
    End If
    ModulAufraeumen
    Set st = Nothing: Set ns = Nothing: Set olApp = Nothing
    Exit Sub

Fehler:
    FehlerLog "BackupAusfuehren", Err.Number, Err.Description
    strStatus = "Abgebrochen"
    Resume Abschluss
End Sub

Private Sub StoreSichern(st As Object, ByVal strZiel As String, ByVal dtAb As Date)
    On Error GoTo Fehler
    mstrOrdner = ""
    mstrStore = st.DisplayName

    If DCount("*", "tblStoreAusschluss", _
              "StoreName='" & Replace(mstrStore, "'", "''") & "'") > 0 Then Exit Sub

    OrdnerSichern st.GetRootFolder, strZiel & "\" & Bereinigen(mstrStore), dtAb
    Exit Sub

Fehler:
    FehlerLog "StoreSichern", Err.Number, Err.Description
End Sub

Private Sub OrdnerSichern(fld As Object, ByVal strPfad As String, ByVal dtAb As Date)
    Dim itms As Object, itm As Object, fldSub As Object
    Dim strOrdner As String, i As Long, n As Long

    On Error GoTo FehlerOrdner
    strOrdner = fld.FolderPath
    mstrOrdner = strOrdner

    If fld.DefaultItemType = olMailItem Then
        Set itms = fld.Items
        If dtAb > 0 Then
            Set itms = itms.Restrict("[ReceivedTime] >= '" & Format(dtAb, "ddddd hh:nn") & "'")
        End If
        n = itms.Count
        For i = 1 To n
            If mbAbbruch Then Exit Sub
            Set itm = ElementHolen(itms, i)
            If Not itm Is Nothing Then MailSichern itm, strPfad
            Set itm = Nothing
            If i Mod 50 = 0 Then DoEvents
        Next
    End If

Unterordner:
    On Error GoTo FehlerUnterordner
    For Each fldSub In fld.Folders
        If mbAbbruch Then Exit Sub
        OrdnerSichern fldSub, strPfad & "\" & Bereinigen(fldSub.Name), dtAb
        mstrOrdner = strOrdner          ' Kontext nach Rückkehr wiederherstellen
    Next
    Exit Sub

FehlerOrdner:
    FehlerLog "OrdnerSichern", Err.Number, Err.Description
    Resume Unterordner

FehlerUnterordner:
    FehlerLog "OrdnerSichern/Unterordner", Err.Number, Err.Description
End Sub

Private Function ElementHolen(itms As Object, ByVal i As Long) As Object
    On Error GoTo Fehler
    Set ElementHolen = itms(i)
    Exit Function
Fehler:
    FehlerLog "ElementHolen", Err.Number, Err.Description, "Element " & i
End Function

Private Sub MailSichern(itm As Object, ByVal strPfad As String)
    Dim strKey As String, strBasis As String, strDatei As String
    Dim strBetreff As String, lngMax As Long, n As Long

    On Error GoTo Fehler
    If itm.Class <> olMail Then Exit Sub

    strBetreff = itm.Subject
    strKey = Left$(MsgKey(itm), 255)
    mrsLog.Seek "=", strKey
    If Not mrsLog.NoMatch Then Exit Sub

    strBasis = Format(itm.ReceivedTime, "yyyy-mm-dd hhnn") & " " & _
               Bereinigen(itm.SenderName) & " " & ChrW(&H2039) & _
               Bereinigen(AbsenderSMTP(itm)) & ChrW(&H203A) & " " & _
               Bereinigen(strBetreff)

    lngMax = 245 - Len(strPfad) - 1 - 4 - 4          ' Pfad, "\", " (n)", ".msg"
    If lngMax < 20 Then lngMax = 20
    strBasis = Trim$(Left$(strBasis, lngMax))

    OrdnerAnlegen strPfad
    strDatei = strPfad & "\" & strBasis & ".msg"
    Do While mfso.FileExists(strDatei)
        n = n + 1
        strDatei = strPfad & "\" & strBasis & " (" & n & ").msg"
    Loop

    itm.SaveAs strDatei, olMSGUnicode

    mrsLog.AddNew
    mrsLog!MsgKey = strKey
    mrsLog!Pfad = strDatei
    mrsLog!Gesichert = Now
    mrsLog!LaufID = mlngLauf
    mrsLog.Update
    mlngAnzahl = mlngAnzahl + 1
    Exit Sub

Fehler:
    FehlerLog "MailSichern", Err.Number, Err.Description, strBetreff, strKey, strDatei
    Resume Aufraeumen
Aufraeumen:
    On Error Resume Next
    If mrsLog.EditMode <> dbEditNone Then mrsLog.CancelUpdate
End Sub


'==============================================================================
' Protokoll
'==============================================================================
Private Function LaufAnlegen(ByVal strModus As String, ByVal strZiel As String) As Long
    Dim rs As DAO.Recordset
    Set rs = mdb.OpenRecordset("tblBackupLauf", dbOpenDynaset)
    rs.AddNew
    rs!Modus = strModus
    rs!Start = Now
    rs!Ziel = Left$(strZiel, 255)
    rs!Anzahl = 0
    rs!Fehler = 0
    rs!Status = "Läuft"
    LaufAnlegen = rs!LaufID
    rs.Update
    rs.Close
End Function

Private Sub LaufAbschliessen(ByVal strStatus As String)
    On Error Resume Next
    If mlngLauf = 0 Then Exit Sub
    mdb.Execute "UPDATE tblBackupLauf SET Ende=Now(), Anzahl=" & mlngAnzahl & _
                ", Fehler=" & mlngFehler & ", Status='" & strStatus & "' " & _
                "WHERE LaufID=" & mlngLauf, dbFailOnError
End Sub

Private Sub FehlerLog(ByVal strProzedur As String, ByVal lngNr As Long, ByVal strText As String, _
                      Optional ByVal strBetreff As String = "", Optional ByVal strKey As String = "", _
                      Optional ByVal strDatei As String = "")
    On Error Resume Next
    mlngFehler = mlngFehler + 1
    Debug.Print Now, strProzedur, lngNr, strText, strBetreff

    If Not mrsFehler Is Nothing Then
        mrsFehler.AddNew
        mrsFehler!LaufID = mlngLauf
        mrsFehler!Zeitpunkt = Now
        mrsFehler!Prozedur = Left$(strProzedur, 64)
        mrsFehler!FehlerNr = lngNr
        mrsFehler!FehlerText = strText
        mrsFehler!Store = Left$(mstrStore, 255)
        mrsFehler!Ordner = mstrOrdner
        mrsFehler!Betreff = Left$(strBetreff, 255)
        mrsFehler!MsgKey = Left$(strKey, 255)
        mrsFehler!Datei = strDatei
        mrsFehler.Update
        If Err.Number <> 0 Then mrsFehler.CancelUpdate
    End If

    If mlngFehler >= MAX_FEHLER Then mbAbbruch = True
End Sub

Private Sub ModulAufraeumen()
    On Error Resume Next
    If Not mrsLog Is Nothing Then mrsLog.Close
    If Not mrsFehler Is Nothing Then mrsFehler.Close
    Set mrsLog = Nothing
    Set mrsFehler = Nothing
    Set mfso = Nothing
End Sub


'==============================================================================
' Hilfsfunktionen
'==============================================================================
Private Function OutlookHolen() As Object
    Dim olApp As Object
    On Error Resume Next
    Set olApp = GetObject(, "Outlook.Application")
    If olApp Is Nothing Then Set olApp = CreateObject("Outlook.Application")
    Set OutlookHolen = olApp
End Function

Private Function MsgKey(itm As Object) As String
    On Error Resume Next
    MsgKey = itm.PropertyAccessor.GetProperty(PR_MSG_ID)
    If Len(MsgKey) = 0 Then MsgKey = "EID:" & itm.EntryID
End Function

Private Function AbsenderSMTP(itm As Object) As String
    On Error Resume Next
    If itm.SenderEmailType = "EX" Then
        AbsenderSMTP = itm.PropertyAccessor.GetProperty(PR_SENDER_SMTP)
        If Len(AbsenderSMTP) = 0 Then _
            AbsenderSMTP = itm.Sender.GetExchangeUser.PrimarySmtpAddress
    Else
        AbsenderSMTP = itm.SenderEmailAddress
    End If
    If Len(AbsenderSMTP) = 0 Then AbsenderSMTP = "unbekannt"
End Function

Private Function Bereinigen(ByVal s As String) As String
    Dim i As Long, c As String
    For i = 1 To Len(s)
        c = Mid$(s, i, 1)
        If AscW(c) < 32 Or InStr("\/:*?""<>|", c) > 0 Then Mid$(s, i, 1) = "_"
    Next
    Do While InStr(s, "  ") > 0: s = Replace(s, "  ", " "): Loop
    s = Trim$(s)
    Do While Len(s) > 0 And (Right$(s, 1) = "." Or Right$(s, 1) = " ")
        s = Left$(s, Len(s) - 1)
    Loop
    If Len(s) = 0 Then s = "_"
    Bereinigen = s
End Function

Private Sub OrdnerAnlegen(ByVal strPfad As String)
    If mfso.FolderExists(strPfad) Then Exit Sub
    OrdnerAnlegen mfso.GetParentFolderName(strPfad)
    mfso.CreateFolder strPfad
End Sub

Private Function ZielpfadWaehlen(ByVal strStart As String) As String
    With Application.FileDialog(4)   ' msoFileDialogFolderPicker
        .Title = "Zielordner für Mail-Backup"
        If Len(strStart) > 0 Then .InitialFileName = strStart & "\"
        If .Show Then ZielpfadWaehlen = .SelectedItems(1)
    End With
End Function

Private Function LetzterZielpfad() As String
    LetzterZielpfad = Nz(DLookup("Ziel", "tblBackupLauf", "LaufID=" & _
                      Nz(DMax("LaufID", "tblBackupLauf", "Ziel Is Not Null AND Ziel<>''"), 0)), "")
End Function

Private Function TabelleExistiert(db As DAO.Database, ByVal strTabelle As String) As Boolean
    Dim tdf As DAO.TableDef
    db.TableDefs.Refresh
    For Each tdf In db.TableDefs
        If StrComp(tdf.Name, strTabelle, vbTextCompare) = 0 Then
            TabelleExistiert = True
            Exit Function
        End If
    Next
End Function

Private Function FeldExistiert(db As DAO.Database, ByVal strTabelle As String, _
                               ByVal strFeld As String) As Boolean
    Dim fld As DAO.Field
    db.TableDefs.Refresh
    db.TableDefs(strTabelle).Fields.Refresh
    For Each fld In db.TableDefs(strTabelle).Fields
        If StrComp(fld.Name, strFeld, vbTextCompare) = 0 Then
            FeldExistiert = True
            Exit Function
        End If
    Next
End Function

Private Function FeldErgaenzen(db As DAO.Database, ByVal strTabelle As String, _
                               ByVal strFeld As String, ByVal strTyp As String) As Boolean
    If FeldExistiert(db, strTabelle, strFeld) Then Exit Function
    db.Execute "ALTER TABLE [" & strTabelle & "] ADD COLUMN [" & strFeld & "] " & strTyp, dbFailOnError
    db.TableDefs.Refresh
    FeldErgaenzen = True
End Function

Die öffentlichen Einstiege

Das Modul hat drei öffentliche Einstiege. DatenmodellAnlegen legt die Tabellen an. KomplettStart fragt nach dem Zielordner und geht alle Postfächer vollständig durch. FolgeStart nimmt den zuletzt verwendeten Zielordner und sichert nur, was seit dem letzten erfolgreichen Lauf dazugekommen ist.

Die Konstanten oben im Modul steuern das Verhalten. MAX_FEHLER begrenzt, nach wie vielen Fehlern ein Lauf abbricht. UEBERLAPPUNG_TAGE legt fest, wie weit ein Folgelauf vor den letzten erfolgreichen Lauf zurückgreift.

Das Datenmodell

Zuerst legt DatenmodellAnlegen die Tabellen an:

  • tblMailBackup merkt sich jede gesicherte Mail.
  • tblBackupLauf protokolliert jeden Lauf.
  • tblBackupFehler hält jeden Fehler mit Kontext fest.
  • tblStoreAusschluss nimmt Postfächer auf, die übersprungen werden sollen.

Die Prozedur darf beliebig oft laufen. Fehlende Tabellen legt sie an, fehlende Spalten ergänzt sie. Eine ältere Version des Datenmodells wird dabei automatisch angehoben.

Der Schlüssel in tblMailBackup ist die Internet-Message-ID der Mail. Sie bleibt gleich, wenn eine Mail in Outlook in einen anderen Ordner verschoben wird. Die interne EntryID von Outlook tut das nicht.

Komplettlauf und Folgelauf

Der Komplettlauf ist für den ersten Start gedacht und für eine gelegentliche Kontrolle, etwa einmal im Monat.

Auch der Komplettlauf erzeugt keine Duplikate. Bereits gesicherte Mails erkennt er an der Message-ID und überspringt sie. Er findet aber Mails, die nachträglich in alte Ordner verschoben wurden und deshalb einem reinen Datumsfilter entgehen würden.

Der Folgelauf ist der wöchentliche Normalfall. Er filtert in Outlook nach dem Empfangsdatum und braucht deshalb nur einen Bruchteil der Zeit.

Der Folgelauf rechnet nur ab dem letzten Lauf mit Status “OK” weiter. Ist eine Mail einmal gescheitert, kommt sie beim nächsten Lauf automatisch wieder dran. Die kleine Function FolgeStartAuto gibt es nur, weil die Makroaktion “AusführenCode” keine Subs aufrufen kann.

Der Kern: Postfächer, Ordner, Mails

Der Kern des Moduls geht in drei Ebenen vor. Er durchläuft alle Postfächer, darin rekursiv alle Ordner und darin jede einzelne Mail.

Jede Ebene hat ihre eigene Fehlerbehandlung. Eine defekte Mail stoppt nicht den Ordner, ein gesperrter Ordner nicht das Postfach und ein nicht erreichbares Online-Archiv nicht den ganzen Lauf. Nur wenn der Zielordner fehlt oder Outlook nicht antwortet, bricht der Lauf sofort ab, mit Status “Abgebrochen” und Klartext im Protokoll.

Bei Absendern aus dem eigenen Exchange liefert Outlook statt der Mailadresse einen internen Verzeichnisnamen. Die echte SMTP-Adresse holt der Code deshalb über den PropertyAccessor. Die Zeichen ‹ und › ersetzen die spitzen Klammern, die in Windows-Dateinamen verboten sind.

Protokoll und Hilfsfunktionen

Protokoll und Fehlerbehandlung laufen über wenige kleine Prozeduren.

FehlerLog schreibt zu jedem Fehler Postfach, Ordnerpfad, Betreff und Zieldatei mit. So findest du die betroffene Mail in Outlook gezielt wieder. Nach 200 Fehlern setzt die Prozedur ein Abbruchsignal, damit eine volle Festplatte keine zehntausend identischen Einträge erzeugt.

Die Hilfsfunktionen räumen Dateinamen auf, legen Ordner an und prüfen das Datenmodell.

Für Dateien und Ordner nutzt der Code das FileSystemObject statt der VBA-Befehle Dir und MkDir. Die alten Befehle scheitern an Unicode-Zeichen, und Betreffzeilen mit Emojis gibt es inzwischen in jedem Postfach.

Fehler des letzten Laufs anzeigen

Diese Abfrage zeigt alle Fehler des letzten Laufs:

SELECT f.Zeitpunkt, f.Prozedur, f.FehlerNr, f.FehlerText, f.Store, f.Ordner, f.Betreff, f.Datei
FROM tblBackupFehler AS f
WHERE f.LaufID = (SELECT Max(LaufID) FROM tblBackupLauf)
ORDER BY f.FehlerID;

Ein Blick in diese Abfrage nach dem wöchentlichen Lauf reicht. Bleibt sie leer, ist alles gesichert.

Wöchentlicher Lauf über die Aufgabenplanung

Für den wöchentlichen Lauf legst du in Access ein Makro mcrMailBackup an. Es enthält die Aktion “AusführenCode” mit FolgeStartAuto() und danach “Beenden”. Die Windows-Aufgabenplanung startet dann diese Befehlszeile:

“C:\Program Files\Microsoft Office\root\Office16\MSACCESS.EXE” “D:\Tools\MailBackup.accdb” /x mcrMailBackup

Die Aufgabe muss mit der Option “Nur ausführen, wenn der Benutzer angemeldet ist” laufen. Outlook braucht das angemeldete Benutzerprofil, sonst gibt es keinen Zugriff auf die Postfächer.

Der Pfad zu MSACCESS.EXE hängt von deiner Office-Installation ab. Bei 32-Bit-Office liegt er unter “Program Files (x86)”.

Wenn dich nicht der Code interessiert, sondern die Frage, welche Sicherung für die Größe deines Betriebs wirtschaftlich passt: Die Anbieter von Hornetsecurity bis Veeam habe ich in Microsoft sichert deine M365-Daten nicht verglichen.

Und jetzt?

Wenn du eine solche Sicherung für eure Postfächer eingerichtet haben möchtest, oder erst einmal wissen willst, wo eure Microsoft-365-Daten heute überhaupt überall liegen: Ein Gespräch dazu kannst du über sesoft.de/kostenloses-erstgespraech-sichern vereinbaren.

Quellen

Autor

Sönke Schäfer ist IT-Berater und Datenarchitekt aus Sierksdorf in Ostholstein. Er entwickelt seit über 25 Jahren Lösungen mit Microsoft Access, VBA und SQL Server für norddeutsche KMU, vor allem rund um gewachsene Bestandssysteme. Als ehemaliger IT-Leiter eines Unternehmens mit rund 300 Mitarbeitenden kennt er Backup-Fragen auch von der Seite, die nachts angerufen wird.

Ähnliche Beiträge

Nach oben scrollen