Vor zu großer PST-Datei warnen

PST-Dateien wachsen oft schnell an, ohne dass man es merkt. Die Folge sind ein verlangsamtes Backup bzw. lange Kopieraktionen auf andere Computer und unter Umständen auch Probleme in Outlook®.

Mit dem folgenden Codebeispiel erhalten Sie eine Warnmeldung beim Starten von Outlook®, wenn Ihre Pst-Datei droht zu groß zu werden und Sie können frühzeitig entsprechende Maßnahmen ergreifen, um die Pst-Datei zu verkleinern. Diese Funktion ist auch in dem Tool AttachmentsManager enthalten.

Zur Verwendung dieses Beispiels beachten Sie bitte die wichtigen Hinweise, sowie den Workshop VBA in Outlook® verwenden. Den Code bitte in das Modul DieseOutlookSitzung kopieren.

Ab Outlook® 2000

Option Explicit
 
Private Sub Application_Startup()
 
    '=====================================================================
    ' Gibt eine Warnung aus, wenn die Pst-Datei eine bestimmte Größe über-
    ' schritten hat.
    ' (c) Peter Marchert - http://www.outlook-stuff.com
    ' 2008-11-09 Version 1.0.0
    ' 2008-11-10 Version 2.0.0
    ' 2008-11-16 Version 2.0.1
    ' 2008-11-23 Version 2.0.2
    ' 2009-09-13 Version 2.0.3
    ' 2009-09-15 Version 2.0.4
    '=====================================================================
    
    Dim strPST As String        ' Pfad und Name der Pst-Datei
    
    Dim dblWarnSize As Double   ' Größe, ab der gewarnt werden soll
    Dim dblSize As Double       ' Aktuelle Größe der Pst-Datei
    
    On Error Resume Next
 
    '---------------------------------------------------------------------
    ' Warngröße festlegen (Standard: 75 MB)
    '---------------------------------------------------------------------
    dblWarnSize = 75
 
    '---------------------------------------------------------------------
    ' Pst-Datei aus Registrierung lesen
    '---------------------------------------------------------------------
    strPST = GetSetting("ESM-Tools\VBA-Projects", "WarnPstSize", "PstFile", "")
 
    '---------------------------------------------------------------------
    ' Noch keine Pst-Datei festgelegt?
    '---------------------------------------------------------------------
    If strPST = "" Then
 
        '-----------------------------------------------------------------
        ' Name und Pfad der PST-Datei festlegen (Standard: Outloook.pst)
        '-----------------------------------------------------------------
        If Left(Outlook.Version, 2) = "9." Then
            strPST = GetOutlookFolder & "\Mailbox.pst"
        Else
            strPST = GetOutlookFolder & "\Outlook.pst"
        End If
 
    End If
 
    '---------------------------------------------------------------------
    ' Datei nicht vorhanden?
    '---------------------------------------------------------------------
    If Dir(strPST) = "" Then
 
        '-----------------------------------------------------------------
        ' Hinweis anzeigen
        '-----------------------------------------------------------------
        If MsgBox("Die Pst-Datei konnte nicht gefunden werden:" & vbCrLf & _
            vbCrLf & strPST & vbCrLf & vbCrLf & _
            "Bitte geben Sie im nächsten Dialog eine Pst-Datei ein.", _
            vbCritical + vbOKCancel) = vbCancel Then Exit Sub
 
        '-----------------------------------------------------------------
        ' Neue Pst-Datei auswählen/eingeben
        '-----------------------------------------------------------------
        strPST = GetPstFile()
 
        '-----------------------------------------------------------------
        ' Wurde die Auswahl/Eingabe abgebrochen, dann beenden, sonst neue
        ' Pst-Datei in Registrierung speichern
        '-----------------------------------------------------------------
        If strPST = "" Then
            Exit Sub
        Else
            Call SaveSetting("ESM-Tools\VBA-Projects", "WarnPstSize", "PstFile", strPST)
        End If
 
    End If
 
    '---------------------------------------------------------------------
    ' Größe der Datei in Byte ermitteln
    '---------------------------------------------------------------------
    dblSize = FileLen(strPST)
 
    '---------------------------------------------------------------------
    ' Größe in MB umrechnen
    '---------------------------------------------------------------------
    dblSize = dblSize / 1024 / 1024
 
    '---------------------------------------------------------------------
    ' Datei größer als festgelegter Wert?
    '---------------------------------------------------------------------
    If dblSize > dblWarnSize Then
        MsgBox "Die Pst-Datei hat die Größe von " & dblWarnSize & " MB" & _
            " überschritten (Größe: " & dblSize & " MB)!" & vbCrLf & vbCrLf & _
            "Sie sollten Daten löschen oder Archivieren (Datei -> Archivieren)," & _
            vbCrLf & "anschließend den Ordner ""Gelöschte Objekte"" leeren und danach" & _
            vbCrLf & "die Datendatei komprimieren.", _
            vbExclamation + vbOKOnly
    End If
 
End Sub
 
Private Function GetOutlookFolder() As String
 
    '=====================================================================
    ' Gibt den versteckten Ordner "Outlook" zurück
    ' 2008-11-21 Version 1.0.0
    '=====================================================================

    Dim objWshShell As Object     ' Windows Script Host
    Dim strFolder As String       ' Spezialordner
    
    On Error Resume Next
 
    '---------------------------------------------------------------------
    ' Instanz des Windows Script Host starten
    '---------------------------------------------------------------------
    Set objWshShell = CreateObject("WScript.Shell")
 
    '---------------------------------------------------------------------
    ' Ordner "Eigene Dateien" ermitteln (Anwendungsdaten geht per VBS nicht)
    '---------------------------------------------------------------------
    strFolder = objWshShell.SpecialFolders("MyDocuments")
 
    '---------------------------------------------------------------------
    ' "Eigenen Dateien" durch Outlook-Ordner in 2000/XP ersetzen
    '---------------------------------------------------------------------
    strFolder = Replace(strFolder, "Eigene Dateien", _
        "Lokale Einstellungen\Anwendungsdaten\Microsoft\Outlook")
 
    '---------------------------------------------------------------------
    ' "Dokumente" durch Outlook-Ordner in Vista ersetzen
    '---------------------------------------------------------------------
    strFolder = Replace(strFolder, "Dokumente\", "\AppData\Roaming\Microsoft\Outlook")
 
    '---------------------------------------------------------------------
    ' Ordner zurückgeben
    '---------------------------------------------------------------------
    GetOutlookFolder = strFolder
 
    '---------------------------------------------------------------------
    ' Clean Up
    '---------------------------------------------------------------------
    Set objWshShell = Nothing
 
End Function
 
Private Function GetPstFile() As String
 
    '=====================================================================
    ' Gibt eine PST-Datei zurück
    ' 2008-11-21 Version 1.0.0
    ' 2008-11-23 Version 2.0.2
    '=====================================================================

    Dim objDialog As Object     ' Dateiauswahldialog
    Dim strTitle As String      ' Hinweis zur Dateiauswahl
    Dim strFile As String       ' Manuelle Eingabe
    Dim strFileName As String   ' Ausgewählte Pst-Datei
    
    On Error Resume Next
 
    '---------------------------------------------------------------------
    ' Hinweis festlegen
    '---------------------------------------------------------------------
    strTitle = "Bitte wählen Sie eine Pst-Datei aus:"
 
    '---------------------------------------------------------------------
    ' Instanz eines Dateiauswahldialogs erzeugen
    '---------------------------------------------------------------------
    Set objDialog = CreateObject("MSComDlg.CommonDialog")
 
    '---------------------------------------------------------------------
    ' Funktioniert nicht unter Windows 2000
    '---------------------------------------------------------------------
    If Not Err.Number = 0 Then
 
        '-----------------------------------------------------------------
        ' Schleife solange durchlaufen, bis eine gültige Eingabe erfolgte
        ' oder der Benutzer die Eingabe abgebrochen hat.
        '-----------------------------------------------------------------
        Do
 
            '-------------------------------------------------------------
            ' Eingabedialog anzeigen
            '-------------------------------------------------------------
            If Left(Outlook.Version, 2) = "9." Then
                strFile = InputBox("Bitte den vollständigen Pfad zur Pst-Datei angeben:", _
                    "Größe von Pst-Datei überwachen", GetOutlookFolder & "\Mailbox.pst")
            Else
                strFile = InputBox("Bitte den vollständigen Pfad zur Pst-Datei angeben:", _
                    "Größe von Pst-Datei überwachen", GetOutlookFolder & "\Outlook.pst")
            End If
 
            '-------------------------------------------------------------
            ' Eingabe abgebrochen?
            '-------------------------------------------------------------
             If strFile = "" Then GoTo ExitProc
 
            '-------------------------------------------------------------
            ' Keine Pst-Datei eingegeben?
            '-------------------------------------------------------------
            If Not Right(LCase(strFile), 4) = ".pst" Then strFile = ""
 
            '-------------------------------------------------------------
            ' Existiert die Datei?
            '-------------------------------------------------------------
            If Dir(strFile) = "" Then
                MsgBox "Die Datei konnte nicht gefunden werden:" & vbCrLf & _
                    vbCrLf & strFile, vbCritical + vbOKOnly
                strFile = ""
            End If
 
        Loop While strFile = ""
 
        '-----------------------------------------------------------------
        ' Dateieingabe zurückgeben
        '-----------------------------------------------------------------
        GetPstFile = strFile
 
        GoTo ExitProc
 
    End If
 
    '---------------------------------------------------------------------
    ' Eigenschaften festlegen
    '---------------------------------------------------------------------
    With objDialog
        .DialogTitle = strTitle
        .Filter = "PST-Dateien|*.pst"
        .InitDir = GetOutlookFolder
    End With
 
    '---------------------------------------------------------------------
    ' Schleife solange durchlaufen, bis eine gültige Auswahl erfolgte oder
    ' der Benutzer die Auswahl abgebrochen hat.
    '---------------------------------------------------------------------
    Do
 
        '-----------------------------------------------------------------
        ' Auswahl anzeigen
        '-----------------------------------------------------------------
        objDialog.ShowOpen
 
        '-----------------------------------------------------------------
        ' Ausgewählte Datei ermitteln
        '-----------------------------------------------------------------
        strFileName = objDialog.FileName
 
        '-----------------------------------------------------------------
        ' Auswahl abgebrochen?
        '-----------------------------------------------------------------
        If strFileName = "" Then GoTo ExitProc
 
        '-----------------------------------------------------------------
        ' Keine Pst-Datei ausgewählt?
        '-----------------------------------------------------------------
        If Not Right(LCase(strFileName), 4) = ".pst" Then
            strFileName = ""
            If MsgBox("Bitte wählen Sie eine Pst-Datei aus." _
                , vbCritical + vbOKCancel) = vbCancel Then GoTo ExitProc
        End If
 
    Loop While strFileName = ""
 
    '---------------------------------------------------------------------
    ' Ausgewählte Datei zurückgeben
    '---------------------------------------------------------------------
    GetPstFile = objDialog.FileName
 
ExitProc:
 
    '---------------------------------------------------------------------
    ' Clean Up
    '---------------------------------------------------------------------
    Set objDialog = Nothing
 
End Function