Outlook Programing - Inbox Cleanup on Quit Event

Does anyone know of VB code that can automagically move Inbox items older than 14 days into a user-defined folder, for example Inbox2, on Outlook client 2003's Application_Quit() event?  We have Inbox retention policies on our Exch 2003 Servers, but they don't fit our needs and Admins really don't have time to customize - hence our need for local VB code.  Thanks!  
BITASCIIAV Technology SupportAsked:
Who is Participating?
Chris BottomleyConnect With a Mentor Commented:
Not a rule as such since rules are driven by send/receive events howevedr in VBA a routine can be coded off the quit application using the following code:

An application code routine, (Application_Quit) for Quit and two supporting code routines, (OLQuit & nav2folder) for the work of moving.  The folder path to where you want the mails moving needs to be correctly defined in OLQuit on the line:
Set fldr = nav2Folder("\\Personal Folders\Inbox\Inbox2")
In this case I established the folder as a subfolder of the inbox but anything goes just about.

Private Sub Application_Quit()
End Sub
Sub OLQuit()
Dim fldr As Outlook.MAPIFolder
Dim objitem As Object
Dim mai As mailitem
Dim strFilter As String
Dim olMailItems As Outlook.Items
    On Error Resume Next
    Set fldr = nav2Folder("\\Personal Folders\Inbox\Inbox2")
    strFilter = "[ReceivedTime] <= '" & Format(DateAdd("d", -14, Date) + TimeSerial(0, 0, 0), "ddddd h:nn AMPM") & "'"
    Set olMailItems = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Items.Restrict(strFilter)
    ' process all the items in this folder
    For Each objitem In olMailItems
        If TypeName(objitem) = "MailItem" Then
            Set mai = objitem
            mai.Move fldr
        ElseIf TypeName(objitem = "ReportItem") Then
        End If
'    Debug.Print Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Items.count & vbTab & olMailItems.count
End Sub
Public Function nav2Folder(foldername As String) As Outlook.MAPIFolder
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olfldr As Outlook.folders
Dim reqdFolder As Outlook.MAPIFolder
Dim arrFolders() As String
Dim nestCount As Integer
    On Error Resume Next
    foldername = Replace(Replace(foldername, "/", "\"), "\\", "")
    If Right(foldername, 1) = "\" Then foldername = Left(foldername, Len(foldername) - 1)
    arrFolders() = Split(foldername, "\")
    Set olApp = Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")
    Set reqdFolder = olNS.folders.item(arrFolders(0))
    For nestCount = 1 To UBound(arrFolders)
        If Not reqdFolder Is Nothing Then
            Set olfldr = reqdFolder.folders
            Set reqdFolder = olfldr.item(arrFolders(nestCount))
            If reqdFolder <> olfldr.item(arrFolders(nestCount)) Then
                reqdFolder.folders.Add (arrFolders(nestCount))
                Set olfldr = reqdFolder.folders
                Set reqdFolder = olfldr.item(arrFolders(nestCount))
            End If
        End If
    Set nav2Folder = reqdFolder
    Set olApp = Nothing
    Set olNS = Nothing
    Set olfldr = Nothing
    Set reqdFolder = Nothing
End Function

Open in new window

Chris BottomleyCommented:
To Create a macro:

Alt + F11 to open the macro editor
  For workbook event handlers:
     In the project tree select as appropriate:
      OUTLOOK      : thisOutlookSession
     In the workpane select as appropriate:
      OUTLOOK      : General
     In the workpane select the required 'event', (i.e. 'open').
     Insert the required macro(s) into the selected subroutine.
  For User Code:
     Insert | Module to insert a code module into the project
     In the project tree select the module.
     Insert the required macro(s) into the selected module, ('Module1' or similar)
Close the Visual Basic Editor.

Check Security as appropriate:

In the application select Tools | Macro | Security
Select Medium
Select OK

Chris BottomleyCommented:
Glad to have helped ... andthanks for the grade.

All Courses

From novice to tech pro — start learning today.