Outlook Retention Policy Workaround – VBA Script

Back at it again with the hacky workarounds!

Today I come to you with a VBA Script that I wrote purely out of necessity due to annoying retention policy settings on Outlook.

The Problem:

The Retention Policy is set to 30 Days on some Exchange Inboxes. You may say, “Just change the retention policy” and normally I’d agree, but in some cases you are NOT allowed to have that permission on Inbox or any folders (personally I’d set the policy to keep forever). However, I make extreme usage of the Follow-up feature in Outlook to ensure that I remember to get tasks done or reply to emails. The issue? Sometimes business emails or requests can take longer than 30 days which will cause mail items and task items to be archived and removed from the right sidebar.

See the thing is, Office 365 mailboxes now comes with a “separate” inbox in addition to your primary inbox called “Online Archive”and as a result of some Microsoft wizardry/hard-coding anything that is in this inbox DOES NOT show up on your tasks sidebar in outlook after they are automatically moved due to the retention policy.

The Solution:

The Worst VBA Hack/Macro ever written.

I’ve written a VBA Script that fires on Outlook startup and every 5 hours. It does a “for loop” over every item in the “Online Archive” Inbox, Sent Items, and Tasks folders and moves them to the main inbox.

Below is the code. (Press ALT + F11 to open VBA Editor in Outlook and ensure you have set Outlook to allow VBA Scripts)

To run this properly right click “Modules” and click create new module then paste the below code.

Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerfunc As Long) As Long
Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long

Public TimerID As Long 'Need a timer ID to eventually turn off the timer. If the timer ID <> 0 then the timer is running

Public Sub ActivateTimer(ByVal nMinutes As Long)
  nMinutes = nMinutes * 1000 * 60 'The SetTimer call accepts milliseconds, so convert to minutes
  If TimerID <> 0 Then Call DeactivateTimer 'Check to see if timer is running before call to SetTimer
  TimerID = SetTimer(0, 0, nMinutes, AddressOf TriggerTimer)
  If TimerID = 0 Then
    MsgBox "The timer failed to activate."
  End If
End Sub

Public Sub DeactivateTimer()
Dim lSuccess As Long
  lSuccess = KillTimer(0, TimerID)
  If lSuccess = 0 Then
    MsgBox "The timer failed to deactivate."
  Else
    TimerID = 0
  End If
End Sub

Public Sub TriggerTimer(ByVal hwnd As Long, ByVal uMsg As Long, ByVal idevent As Long, ByVal Systime As Long)
  MsgBox "Processing Outlook Items..."
  Call ProcessOutlookItems
End Sub

Sub ProcessOutlookItems()
    Dim objNS As Outlook.NameSpace
    Dim objFolder As Outlook.MAPIFolder
    Set objNS = GetNamespace("MAPI")
    
    Set Archive = objNS.Folders("Online Archive - username@domain.com")
    Set Archive_Inbox = Archive.Folders("Inbox")
    Set Archive_Sent_Items = Archive.Folders("Sent Items")
    Set Archive_Tasks = Archive.Folders("Tasks")
    
    Set Main = objNS.Folders("username@domain.com")
    Set Main_Inbox = Main.Folders("Inbox")
    Set Main_Sent_Items = Main.Folders("Sent Items")
    Set Main_Tasks = Main.Folders("Tasks")
    
    On Error GoTo ErrorHandler
    Dim Msg As Outlook.MailItem

    Call MoveToFolder(Archive_Inbox, Main_Inbox)
    Call MoveToFolder(Archive_Sent_Items, Main_Sent_Items)
    Call MoveToFolder(Archive_Tasks, Main_Tasks)

ProgramExit:
    Exit Sub
ErrorHandler:
    MsgBox Err.Number & " - " & Err.Description
    Resume ProgramExit
End Sub

Sub MoveToFolder(ByVal FolderToParse As Folder, ByVal Destination As Folder)
    
    On Error GoTo ErrorHandler
    
    Dim Msg As Outlook.MailItem
    Dim Task As Outlook.TaskItem
    
    For Each Item In FolderToParse.Items
    
    DoEvents
    
    If TypeName(Item) = "MailItem" Then
        If Item.FlagStatus = olFlagMarked Then
            Item.Move Destination
        End If
    End If
    
    If TypeName(Item) = "TaskItem" Then
        If Item.Status = olFlagMarked Then
            Item.Move Destination
        End If
    End If
    
    Next Item
    
ProgramExit:
    Exit Sub
ErrorHandler:
    MsgBox Err.Number & " - " & Err.Description
    Resume ProgramExit
End Sub

Next, paste the below into “ThisOutlookSession” which will be located on the right sidebar under “Microsoft Outlook Objects”

Private Sub Application_Quit()
  If TimerID <> 0 Then Call DeactivateTimer 'Turn off timer upon quitting **VERY IMPORTANT**
End Sub

Private Sub Application_Startup()
    Call ProcessOutlookItems
    Call ActivateTimer(300) 'Set timer to go off every 1 minute
End Sub

Wew. This was a ton of work for absolutely no reason.

Credit to @niton on StackOverflow for the TriggerTimer Code