Script: Autocategorize mail when read

This script is good when you have a shared mailbox that several people are reading and you wanna know who has read which and what email. This script only works if you have category view on.

Script functionality: When clicking a mail in the mailbox, it will make a category with your name and move that clicked email to the category.


1. Start Outlook

2. Press ALT+F11 to go into VB editor

3. Expand Project1 so Microsoft Outlook Objects is visible

4. Expand Microsoft Outlook Objects so ThisOutlookSession becomes visible

5. Click ThisOutlookSession

6. Paste in this code below in the white field on the right window

7. Edit row Set olkFolder = OpenOutlookFolder("Mailbox - name\Inbox").Items to name on your mailbox. (this example is targeting Inbox folder)

8. Click Save button.9. Restart Outlook to have the script start working


Code:

Public WithEvents olkFolder As Outlook.Items

Private Sub Application_MAPILogonComplete()
'Change the folder path on the following line to that of the fodler you want to monitor
Set olkFolder = OpenOutlookFolder("Mailbox - name\Inbox").Items
End Sub

Private Sub olkFolder_ItemChange(ByVal Item As Object)
'If the item is marked as read
If Item.UnRead = False Then
If TypeName(Application.ActiveInspector) <> "Nothing" Then
If Item.Subject = Application.ActiveInspector.CurrentItem.Subject Then
'If no category is set already
If Item.Categories = "" Then
'Set the category and save the change
Item.Categories = Replace(Session.CurrentUser, ",", "")
Item.Save
End If
End If
End If
End If
End Sub


Function IsNothing(obj)
If TypeName(obj) = "Nothing" Then
IsNothing = True
Else
IsNothing = False
End If
End Function

Function OpenOutlookFolder(strFolderPath As String) As Outlook.MAPIFolder
Dim arrFolders As Variant, _
varFolder As Variant, _
olkFolder As Outlook.MAPIFolder
On Error GoTo ehOpenOutlookFolder
If strFolderPath = "" Then
Set OpenOutlookFolder = Nothing
Else
If Left(strFolderPath, 1) = "\" Then
strFolderPath = Right(strFolderPath, Len(strFolderPath) - 1)
End If
arrFolders = Split(strFolderPath, "\")
For Each varFolder In arrFolders
If IsNothing(olkFolder) Then
Set olkFolder = Session.Folders(varFolder)
Else
Set olkFolder = olkFolder.Folders(varFolder)
End If
Next
Set OpenOutlookFolder = olkFolder
End If
On Error GoTo 0
Exit Function
ehOpenOutlookFolder:
Set OpenOutlookFolder = Nothing
On Error GoTo 0
End Function