Highlight your Inbox when subfolders have unread messages (Outlook)

[cthaxter]

If you have (or want to have) rules set up in Outlook such that you have new messages automatically filtered into various subfolders within your mailbox, you would have to always have your folders fully expanded in order to see which folders have new messages (causing those folders to be highlighted). Wouldn't you like your Inbox and/or another relatively prominent folder to be highlighted every time you have new messages in your other folders deep down?

Here is some code that will accomplish this. It puts a PostItem in the prominent folder(s), and marks it as unread every time you have unread messages in your subfolders, or any other folders that you designate.

Just be sure to customize this code according to your mailbox structure and your system of root folders and their designated subfolders. To do this, make sure olMailBox has the correct value in the main procedure, and then customize the NewInFolder procedure. That's all you need to do. You don't need to hard-code your entire mailbox structure, at all.

In my example, I've set up my Inbox to be highlighted every time I have unread messages in my Data folder. And my Dummy2 folder, which is a subfolder of Dummy1, is set to be highlighted every time I have unread messages in all of its subfolders: Dummy3 through Dummy7, where each subsequent folder is a subfolder of the previous one.

Also, my code is set up to handle up to seven levels of folders (a top level and six levels beneath). It's fairly obvious as to how you can modify the code to handle more levels.

I've only tested this in Outlook 2000; but as far as I know, it should work in other versions as well.

(Additional Keywords: 97, 2002, XP, automatic, rule)

Place the following line of code in your NewMail and Startup events in ThisOutlookSession:

Call HighlightRootFolders

Place the following code in a new module:

Option Explicit

Dim olNS As NameSpace
Dim olApp As Outlook.Application
Dim olMailBox As MAPIFolder
Dim arrPosts(50) As PostItem

Sub HighlightRootFolders()
'Call this procedure from the NewMail event and the Startup event.

Dim A As Integer
Dim B As Integer
Dim C As Integer
Dim D As Integer
Dim E As Integer
Dim F As Integer
Dim G As Integer
Dim olLevel1Folder As MAPIFolder
Dim olLevel2Folder As MAPIFolder
Dim olLevel3Folder As MAPIFolder
Dim olLevel4Folder As MAPIFolder
Dim olLevel5Folder As MAPIFolder
Dim olLevel6Folder As MAPIFolder
Dim olLevel7Folder As MAPIFolder

Set olApp = CreateObject("Outlook.Application&quot
Set olNS = olApp.GetNamespace("MAPI&quot
Set olMailBox = olNS.Folders.Item("Mailbox - Christopher Thaxter&quot

For A = 1 To olMailBox.Folders.Count
Set olLevel1Folder = olMailBox.Folders.Item(A)
Call NewInFolder(olLevel1Folder)
For B = 1 To olLevel1Folder.Folders.Count
Set olLevel2Folder = olLevel1Folder.Folders.Item(B)
Call NewInFolder(olLevel2Folder)
For C = 1 To olLevel2Folder.Folders.Count
Set olLevel3Folder = olLevel2Folder.Folders.Item(C)
Call NewInFolder(olLevel3Folder)
For D = 1 To olLevel3Folder.Folders.Count
Set olLevel4Folder = olLevel3Folder.Folders.Item(D)
Call NewInFolder(olLevel4Folder)
For E = 1 To olLevel4Folder.Folders.Count
Set olLevel5Folder = olLevel4Folder.Folders.Item(E)
Call NewInFolder(olLevel5Folder)
For F = 1 To olLevel5Folder.Folders.Count
Set olLevel6Folder = olLevel5Folder.Folders.Item(F)
Call NewInFolder(olLevel6Folder)
For G = 1 To olLevel6Folder.Folders.Count
Set olLevel7Folder = olLevel6Folder.Folders.Item(G)
Call NewInFolder(olLevel7Folder)
Next G
Next F
Next E
Next D
Next C
Next B
Next A

'make sure the postitems do not get archived, by modifying them once per day (an arbitrary period, which must be smaller than the archive period)
A = 1
Do While Not arrPosts(A) Is Nothing
If CDate(Format(arrPosts(A).LastModificationTime, &quot;m/d/yyyy&quot) < CDate(Format(Date, &quot;m/d/yyyy&quot) Then 'if it has not been modified today
arrPosts(A).Mileage = &quot;&quot; 'easiest and least visible field to modify; not changing its value suffices as a modification
arrPosts(A).Save
End If
A = A + 1
Loop

'release object variables
Set olLevel1Folder = Nothing
Set olLevel2Folder = Nothing
Set olLevel3Folder = Nothing
Set olLevel4Folder = Nothing
Set olLevel5Folder = Nothing
Set olLevel6Folder = Nothing
Set olLevel7Folder = Nothing
Set olMailBox = Nothing
For A = 0 To 50
Set arrPosts(A) = Nothing
Next
Set olNS = Nothing
Set olApp = Nothing
End Sub

Sub NewInFolder(olfolder As MAPIFolder)
Dim olDummy2 As MAPIFolder
Dim olInbox As MAPIFolder
'Assign your root folders to a variable each
Set olDummy = olMailBox.Folders.Item(&quot;Dummy1&quot.Folders.Item(&quot;Dummy2&quot
Set olInbox = olMailBox.Folders.Item(&quot;Inbox&quot

'Assign each subfolder to its designated root folder
'&quot;Subfolders&quot; need not be actual subfolders of the &quot;root&quot; folder
Select Case olfolder.Name
Case Is = &quot;dummy3&quot;
Call HighlightUpper(olDummy2, olfolder)
Case Is = &quot;dummy4&quot;
Call HighlightUpper(olDummy2, olfolder)
Case Is = &quot;dummy5&quot;
Call HighlightUpper(olDummy2, olfolder)
Case Is = &quot;dummy6&quot;
Call HighlightUpper(olDummy2, olfolder)
Case Is = &quot;dummy7&quot;
Call HighlightUpper(olDummy2, olfolder)
Case Is = &quot;Data&quot;
Call HighlightUpper(olInbox, olfolder)
End Select
End Sub

Sub HighlightUpper(olUpper As MAPIFolder, olLower As MAPIFolder)
Dim olPost As PostItem
Dim X As Integer

Set olPost = olUpper.Items.Find(&quot;[Subject] = 'New Mail in Subfolder'&quot
If olPost Is Nothing Then
Set olPost = olApp.CreateItem(olPostItem)
olPost.Subject = &quot;New Mail in Subfolder&quot;
olPost.Body = &quot;If this post item is unread, there are unread messages in your subfolder(s).&quot;
olPost.Post
If olUpper.Name <> &quot;Inbox&quot; Then olPost.Move olUpper 'default location of new postitems is the Inbox
End If

X = 1
Do While Not arrPosts(X) Is Nothing And Not olPost Is arrPosts(X) 'array item contains something and it's not olPost
X = X + 1
If X = 50 Then Exit Do
Loop
'if olpost was found, this is not the first time around
If arrPosts(X) Is olPost Then
'do not change the unread status of the postitem unless lower folder is unread
If olLower.UnReadItemCount > 0 Then 'unread
olPost.UnRead = True
End If
End If

'if olpost was not found, add it to the array and treat this as the first time around
If arrPosts(X) Is Nothing And Not arrPosts(X - 1) Is olPost Then
Set arrPosts(X) = olPost
'Mark the postitem consistent with the lower folder
If olLower.UnReadItemCount = 0 Then 'read
olPost.UnRead = False
Else 'unread
olPost.UnRead = True
End If
End If
End Sub