Outlook Macro: Move read messages from inbox to folders

Being handed over a blackberry from my employer recently to monitor support e-mails, what I found out was that any e-mails that were picked by my rules and routed to some folders did not show up in my BB inbox. There are some settings that you can use on the handheld or the BB desktop manager to start syncing those folders as well. However since the BB was admin owned by my employer I could do neither of them.

So the plan was to disable these rules, let all mails get routed to my inbox and then have rules to route them to folders once I have read the rules or at-least it shows on BB. Unfortunately MS Outlook does not support rules which would run once you have read e-mails. They only get evaluated against mails coming from the exchange server. So I need an outlook macro script which would kick in every say 30 mins and move all messages from my inbox meeting the rules criteria to specific folders. After spending a few unsuccessful hours on the web trying to land an out-of-the box script I decided to write my own. It turned out to be easy, fun and educating. As a do-gooder I would like to share the macro script with you to save you a few hours…

Put the following script in ThisOutlookSession of your macro:

Private Sub Application_Startup()

Call Timers.ActivateTimer(30)  ‘This sets timer to 30 mins, It can be set to any value

End Sub

Private Sub Application_Quit()

If TimerID <> 0 Then Call Timers.DeactivateTimer ‘Please do not exclude this step, this will kill the timer we created

End Sub

Put the following script in the module of your macro:

Option Explicit

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

Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long

Private TimerID As Long 'Timer object

Public Sub ArchiveIt()

Dim ns As Outlook.NameSpace

Set ns = Application.GetNamespace("MAPI")

'Open inbox folder

Dim folder As Outlook.folder

Set folder = ns.GetDefaultFolder(olFolderInbox)

Dim destinationFolder As Outlook.folder

'Move all mails from xyz@abc.com to Inbox/Production Support/xyz

Set destinationFolder = folder.Folders("Production Support").Folders("xyz")

MoveMailsByFilter destinationFolder, folder, "[SenderEmailAddress] = 'xyz@abc.com'"

End Sub

Private Sub MoveMailsByFilter(ByVal destinationFolderHandle As Outlook.folder, ByVal inboxFolderHandle As Outlook.folder, ByVal filterText As String)

Dim filteredList As Outlook.Items

Set filteredList = inboxFolderHandle.Items.Restrict(filterText)

For i = filteredList.Count To 1 Step -1

filteredList.Item(i).Move destinationFolderHandle

Next i

End Sub

Public Sub ActivateTimer(ByVal nMinutes As Long)

nMinutes = nMinutes * 1000 * 60 'Convert time to milliseconds.

If TimerID <> 0 Then Call DeactivateTimer 'Remove any existing timers.

TimerID = SetTimer(0, 0, nMinutes, AddressOf TriggerTimer)

If TimerID = 0 Then

MsgBox "Distributor failed. Contact administrator"

End If

End Sub

Public Sub DeactivateTimer()

Dim lSuccess As Long

lSuccess = KillTimer(0, TimerID)

End Sub

Private Sub TriggerTimer(ByVal hwnd As Long, ByVal uMsg As Long, ByVal idevent As Long, ByVal Systime As Long)

Distributor.ArchiveIt

End Sub

You can play around with the different properties exposed on filteredList.Item like filteredList.Item(i).Unread = false (to pick only read messages) to fine tune your archiving criteria. Enjoy!