My New Category Filing System In Outlook 2007

I always try to keep my Inbox at a manageable level (for me that is less than 50 items). Everything that I have dealt with (or I need for reference) I file in a specific reference folder

ASIDE: I know Getting Things Done, GTD, advocates just deleting it but I’m one of those guys that doesn’t like to delete anything – I have no mailbox quota as we dogfood our own Archiving / Mailbox size control application, Archive One (shameless plugging).

Anyway, when the method I used for filing was to assign each email a category (or multiple categories) and then run an Outlook macro to copy it to a folder with the same name as the category. In Outlook 2003 assigning a category was a bit of a pain / lengthy process so I wrote a bunch of macros to automate this from the click of a single toolbar button.

Now I have Office 2007, assigning categories is much simpler, so I ditched the ‘Assign Category XXX’ macros and just wrote ‘FileBasedOnCategory’ macros. I needed one to process just the selected item and another for processing all items in my Inbox.

Now categorizing is a simple right click and select and storing a single toolbar button away…

Here’s the macros I wrote:

Public Const ReferenceFolder = "zz Reference"

Public Sub CategorizeThis()

    ' Assign a category to the selected objects
    Dim sCurrent As String, obj As Object, objList As Object

    Set objList = Application.ActiveExplorer.Selection

    For Each obj In objList

        StoreObject obj

    Next

    Set obj = Nothing
    Set objList = Nothing

End Sub


Public Sub CategorizeAll()

    ' Assign a category to the selected objects
    Dim sCurrent As String, obj As Object, objList As Object

    Set objList = Application.ActiveExplorer.CurrentFolder.Items

    For Each obj In objList

        StoreObject obj

    Next

    Set obj = Nothing
    Set objList = Nothing

End Sub



Private Sub StoreObject(ByRef obj As Object)

    Dim vCat As Variant, aCats() As String, o As Object, sFolder As String, bOK As Boolean

    bOK = True

    If obj.Categories <> "" Then

        aCats = Split(obj.Categories, ",")
        For Each vCat In aCats()

            sFolder = ReferenceFolder & "" & Trim(CStr(vCat))
            If CreateMAPIFolder(sFolder) Then

                Set o = obj.Copy
                o.Move GetMAPIFolder(sFolder)

            Else

                MsgBox ("Could not create folder : " & sFolder)
                bOK = False
                Exit For

            End If

        Next
        If bOK Then obj.Delete

    End If

End Sub


Private Function CreateMAPIFolder(ByVal sFolder As String) As Boolean

    ' Create a MAPIFolder object of the specified name if none exists
    Dim objNS As NameSpace, objParent As MAPIFolder, objChild As MAPIFolder
    Set objNS = Application.GetNamespace("MAPI")
    Set objParent = objNS.GetDefaultFolder(olFolderInbox)

    Dim aFolders() As String, vFolder As Variant
    aFolders = Split(sFolder, "")
    For Each vFolder In aFolders
        On Error Resume Next
        Set objChild = objParent.Folders(Trim(CStr(vFolder)))
        If Err Then Set objChild = objParent.Folders.Add(Trim(CStr(vFolder)))
        Err.Clear
        Set objParent = objChild
    Next
    If (InStr(objChild.FolderPath, sFolder) > 0) Then
        CreateMAPIFolder = True
    Else
        CreateMAPIFolder = False
    End If
    Set objParent = Nothing
    Set objChild = Nothing
    Set objNS = Nothing

End Function


Private Function GetMAPIFolder(ByVal FolderName As String) As Object

    ' Returns a MAPIFolder object of the specified name
    Dim objNS As NameSpace, objParent As MAPIFolder, objChild As MAPIFolder
    Set objNS = Application.GetNamespace("MAPI")
    Set objParent = objNS.GetDefaultFolder(olFolderInbox)

    Dim aFolders() As String, vFolder As Variant
    aFolders = Split(FolderName, "")
    For Each vFolder In aFolders
        Set objChild = objParent.Folders(CStr(vFolder))
        Set objParent = objChild
    Next
    Set GetMAPIFolder = objChild
    Set objParent = Nothing
    Set objChild = Nothing
    Set objNS = Nothing

End Function

purchase term paper

Related Posts

Leave a Reply Cancel reply