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()
1
2
3
4
5
6
7
8
9
10
11
12
13
' 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()
1
2
3
4
5
6
7
8
9
10
11
12
13
' 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)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
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
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
' 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
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
' 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