Private Const ARCHIVE_STOREID As String = ""
Private Const ARCHIVE_ENTRYID As String = ""

Public Function GetArchiveIDs() As Outlook.MAPIFolder
  Dim Folder As Outlook.MAPIFolder
  Dim Ns As Outlook.NameSpace

  ' Waehle manuell den Archivordner
  Set Ns = Application.GetNamespace("MAPI")
  Set Folder = Ns.PickFolder
  If Not Folder Is Nothing Then
    Set GetArchiveIDs = Folder

    ' Druckt die IDs ins Direktfenster
    ' Die Werte koennten manuell einmalig in den
    ' Konstanten gespeichert werden.
    Debug.Print "ARCHIVE_STOREID: " & Folder.StoreID
    Debug.Print "ARCHIVE_ENTRYID: " & Folder.EntryID
  End If
End Function

Public Sub ArchivItems()
  Dim SrcFolder As Outlook.MAPIFolder
  Dim DestFolder As Outlook.MAPIFolder
  Dim Items As Outlook.Items
  Dim obj As Object
  Dim Appt As Outlook.AppointmentItem
  Dim Ns As Outlook.NameSpace
  Dim DueDate As Date
  Dim i&
  Dim Counter&

  Set Ns = Application.GetNamespace("MAPI")

  ' Archivordner ermitteln
  ' Wenn IDs nicht schon vorhanden, dann muss
  ' User waehlen
  Select Case 0
  Case Len(ARCHIVE_STOREID), Len(ARCHIVE_ENTRYID)
    Set DestFolder = GetArchiveIDs
    If DestFolder Is Nothing Then
      'Abbruch
      Exit Sub
    End If
  Case Else
    ' Ordner anhand der IDs ermitteln
    Set DestFolder = Ns.GetFolderFromID(ARCHIVE_ENTRYID, ARCHIVE_STOREID)
  End Select

  ' Bsp: Einen Tag vom aktuellen Datum zurueckrechnen:
  DueDate = DateAdd("d", -1, Now)

  ' Standardkalender
  Set SrcFolder = Ns.GetDefaultFolder(olFolderCalendar)
  Set Items = SrcFolder.Items

  ' Alle Termine durchlaufen
  ' Da die Anzahl der Listeelemente ggf. reduziert wird,
  ' muss die Schleife rueckwaerts laufen.
  For i = Items.Count To 1 Step -1
    Set obj = Items(i)
    If TypeOf obj Is Outlook.AppointmentItem Then
      Set Appt = obj
      ' Wenn ein Termin aelter als das errechnete
      ' Faelligkeitsdatum ist, dann in den Zielordner verschieben.
      If DateDiff("s", Appt.End, DueDate, vbUseSystemDayOfWeek, vbUseSystem) > 0 Then
        Appt.Move DestFolder
        Set Appt = Nothing
        Counter = Counter + 1
      End If
    End If
  Next

  ' Bericht
  MsgBox "Es wurde(n) " & Counter & " Element(e) verschoben.", vbInformation
End Sub