StartDownloadsServiceSamplesWorkshopsContact DeutschEnglish
Awarded by
Microsoft since 2005:
mvp logo
VBOffice Info
Privacy Policy
Calendar: Archive items
Author: Michael BauerHomepage
Date: 07.02.2007Accessed: 23024

We are very sorry! This description is not translated yet. Anyway, please try the code as it is self-explanatory.

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
    Set DestFolder = GetArchiveIDs
    If DestFolder Is Nothing Then
      Exit Sub
    End If
  Case Else
    ' Ordner anhand der IDs ermitteln
  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

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

ReplyAll alerts you before unintentionally replying all, or if you are a confidential BCC recipient of the ... [more]


Access the master category list in the blink of an eye, share your categories in a network, get a reminder service, and ... [more]


SAM automatically sets the sender, signature, and folder for sent items, for instance based on the recipient ... [more]


OLKeeper reliably prevents users from closing their Outlook window and thus possibly missing reminders or ... [more]