Auto-Archivierungseinstellungen drucken

Die Autoarchivierung wird in Outlook genutzt, um alte Elemente in eine Archivdatei zu verschieben oder zu löschen. Die Einstellungen können Sie für jeden Ordner einzeln festlegen: Klicken Sie mit rechts auf den Ordnernamen, dann auf Eigenschaften, AutoArchivierung. Leicht passiert es, dass man einen Ordner vergißt. Und es gibt in Outlook keine Funktion, die eine Übersicht aller Einstellungen anzeigt.

Die folgenden Makros drucken so eine Liste ins Direktfenster (strg+g) im VBA-Editor. Starten Sie die Funktion PrintAutoArchiveSettings z.B. über ALT+F8 und wählen Sie dann den Startordner aus. Gedruckt werden die Einstellungen für den Startordner und alle seine Unterordner. Wenn für einen Ordner die Archivierung festgelegt ist und der Ordner nicht die Standardeinstellungen verwendet, dann wird auch der Name der Archivdatei gedruckt.

Wenn für einen Ordner 'Standardeinstellungen' gewählt ist, kann das ebenfalls archivieren, nicht archivieren oder löschen bedeuten. Die Standardeinstellungen finden Sie aber schnell in den Optionen, so dass dafür keine Programmierung nötig ist. Wer auch das per Code auslesen möchte, findet die Werte in der Registry unter HKEY_CURRENT_USER/Software/Microsoft/Office/xx.0/Outlook/Preferences. Ersetzen Sie 'xx' durch die Outlook-Version.

Damit dieses Beispiel funktioniert, müssen Sie die Redemption installieren, die für den Privatgebrauch kostenlos ist. Setzen Sie nach der Installation über Extras/Verweise einen Verweis auf die Redemption * Library.

  So fügen Sie Makros in Outlook ein

Public Sub PrintAutoArchiveSettings()
  Dim Session As Redemption.RDOSession
  Dim Folder As Redemption.RDOFolder
  
  Set Session = CreateObject("redemption.rdosession")
  'Die folgende Zeile funktioniert erst ab OL 2003. Für ältere Versionen rufen Sie
  'stattdessen Session.Logon auf
  Session.MAPIOBJECT = Application.Session.MAPIOBJECT
  
  Set Folder = Session.PickFolder
  If Folder Is Nothing Then Exit Sub
  
  GetAgingProperties Folder, 0
  LoopFolders Folder.Folders, True, 1
End Sub

Private Sub LoopFolders(Folders As Redemption.RDOFolders, _
  ByVal Recursive As Boolean, _
  ByVal Indent As Long _
)
  Dim Folder As Redemption.RDOFolder
  For Each Folder In Folders
    GetAgingProperties Folder, Indent
    If Recursive Then
      LoopFolders Folder.Folders, Recursive, Indent + 1
    End If
  Next
End Sub

Private Sub GetAgingProperties(Folder As Redemption.RDOFolder, ByVal Indent As Long)
  On Error Resume Next
  Dim Item As Redemption.RDOMail
  Dim msg$
  Const AGE_FOLDER As Long = &H6857000B
  Const DELETE_ITEMS As Long = &H6855000B
  Const FILE_NAME As Long = &H6859001E
  Const GRANULARITY As Long = &H36EE0003
  Const AGING_PERIOD As Long = &H36EC0003
  Const AGING_DEFAULT As Long = &H685E0003
  
  If Folder.DefaultMessageClass = "IPM.Configuration" Then Exit Sub

  msg = String(Indent, vbTab) & Folder.Name & ": "  
  Set Item = Folder.HiddenItems.Find("[MessageClass]='IPC.MS.Outlook.AgingProperties'")
  
  If Not Item Is Nothing Then
    If Item.Fields(AGE_FOLDER) = True Then
      Select Case Item.Fields(AGING_DEFAULT)
      Case 0, 1
        If Item.Fields(DELETE_ITEMS) = True Then
          msg = msg & "Elemente löschen"
        Else
          msg = msg & "Elemente archivieren"
          If Item.Fields(FILE_NAME) Then
            msg = msg & " (" & Item.Fields(FILE_NAME) & ")"
          End If
        End If
      Case 3
        msg = msg & "Standardeinstellungen"
      End Select
    ElseIf Item.Fields(AGING_DEFAULT) = 3 Then
      msg = msg & "Standardeinstellungen"
    Else
      msg = msg & "Keine Archivierung"
    End If
  Else
    msg = msg & "Keine Archivierung"
  End If
  
  Debug.Print msg
End Sub