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 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 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 - firstname.lastname@example.org") Set Archive_Inbox = Archive.Folders("Inbox") Set Archive_Sent_Items = Archive.Folders("Sent Items") Set Archive_Tasks = Archive.Folders("Tasks") Set Main = objNS.Folders("email@example.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.