I am on way too many email lists. Between my IT career, space related sites, science R&D, Marine Corps, SCA, skydiving or what have you. I got tired of making rules for each list and finally decided to use programming to skin this cat. It took some time looking up all the Outlook objects but this is what I finally came up with in VBA Most of this could convert to .NET pretty easily if the need was there.
' ENTRY POINT #1: Called by a toolbar action (button) '
'---------------------------------------------------------------------------------------'
Public Sub RunSorter()
On Error GoTo errHandler
Dim target As String
Dim varEntryIDs
Dim objItem As Object
Dim i As Integer
Dim message As String
Dim myFolder As Outlook.MAPIFolder
Dim x As Integer
myFolder = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
For x = 1 To myFolder.Items.Count
If (TypeName(myFolder.Items(x)) = "MailItem") Then
target = sortIncoming(myFolder.Items(x))
If Len(target) > 0 Then
message = message & vbCrLf & target
End If
End If
Next x
message = message & vbCrLf & "--[ DONE ]------------------------------------"
Call MsgBox(message, vbOKOnly, "Messages moved...")
exitHandler:
Exit Sub
errHandler:
Resume Next
End Sub
'---------------------------------------------------------------------------------------'
' ENTRY POINT #2: Automatically runs when new mail is dropped in '
'---------------------------------------------------------------------------------------'
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
On Error GoTo errHandler
Dim target As String
Dim varEntryIDs
Dim objItem As Object
Dim i As Integer
varEntryIDs = Split(EntryIDCollection, ",")
For i = 0 To UBound(varEntryIDs)
objItem = Application.Session.GetItemFromID(varEntryIDs(i))
Debug.Print("NewMailEx " & objItem.Subject)
If (TypeName(objItem) = "MailItem") Then
target = sortIncoming(objItem)
End If
Next
exitHandler:
Exit Sub
errHandler:
Resume Next
End Sub
'---------------------------------------------------------------------------------------'
' '
'---------------------------------------------------------------------------------------'
Private Function sortIncoming(ByVal mail As MailItem) As String
On Error GoTo errHandler
Dim targetPst As String
Dim targetFolders
Dim sourceDomain As String
Dim sourceList As String
Dim sourceAddress As String
Dim message As String
Dim myExplorers As Outlook.Explorers
Dim pstFolder As MAPIFolder
Dim targetFolder As MAPIFolder
Dim pstFolderFound As Boolean
Dim targetFolderFound As Boolean
Dim isGoodAddress As Boolean
Dim isValidMove As Boolean
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim myArray() As String
Dim myXml As String
Call MakeArray(myArray)
'sourceAddress = GetAddress(mail)
For k = 1 To mail.Recipients.Count
sourceAddress = mail.Recipients.Item(k).Address
message = ""
If (InStr(1, sourceAddress, "@") > 0) Then
sourceDomain = LCase(Mid(sourceAddress, InStr(1, sourceAddress, "@") + 1))
sourceList = LCase(Left(sourceAddress, InStr(1, sourceAddress, "@") - 1))
pstFolderFound = False
targetFolderFound = False
myExplorers = mail.Application.Explorers
isGoodAddress = False
isValidMove = False
' Handle the Advice series of lists...
If (InStr(1, sourceDomain, "advice.com") > 0) Then
If (sourceDomain = "aspadvice.com") Then
sourceList = "AspAdvice-" & sourceList
ElseIf (sourceDomain = "sqladvice.com") Then
sourceList = "SqlAdvice-" & sourceList
ElseIf (sourceDomain = "xmladvice.com") Then
sourceList = "XmlAdvice-" & sourceList
End If
isGoodAddress = True
targetPst = "Tech Communities"
targetFolders = Split(sourceList, "-")
End If
If (InStr(1, sourceDomain, "yahoogroups.com") > 0) Then
For x = 0 To UBound(myArray, 2)
If UCase(sourceList) = UCase(myArray(1, x)) Then
isGoodAddress = True
targetFolders = Split(myArray(2, x), "-")
targetPst = myArray(0, x)
Exit For
End If
Next x
End If
If isGoodAddress Then
' These are the top level (PST) folders...
For i = 1 To myExplorers.Session.Folders.Count
' Are we in the right folder yet?
If (UCase(myExplorers.Session.Folders.Item(i)) = UCase(targetPst)) Then
pstFolder = myExplorers.Session.Folders.Item(i)
targetFolder = pstFolder
' Let's create the new folder if it does not exist (recursive)...
For j = 0 To UBound(targetFolders)
targetFolder = GetMakeFolder((targetFolders(j)), targetFolder)
Next j
' Now, let's move the mail there and make sure it's marked as unread...
Call mail.Move(targetFolder)
mail.UnRead = True
isValidMove = True
message = mail.Subject
Exit For
End If
Next i
targetFolderFound = False
pstFolderFound = False
End If
End If
If isValidMove Then
Exit For
End If
Next k
exitHandler:
sortIncoming = message
Exit Function
errHandler:
Resume Next
End Function
'---------------------------------------------------------------------------------------'
' '
'---------------------------------------------------------------------------------------'
Private Function GetMakeFolder(ByVal targetName As String, ByVal targetFolder As MAPIFolder) As MAPIFolder
On Error GoTo errHandler
Dim targetFolderFound As Boolean
Dim newTargetFolder As MAPIFolder
For i = 1 To targetFolder.Folders.Count
If (targetFolder.Folders(i) = targetName) Then
targetFolderFound = True
newTargetFolder = targetFolder.Folders(i)
Exit For
End If
Next i
If Not targetFolderFound Then
newTargetFolder = targetFolder.Folders.Add(targetName)
End If
exitHandler:
GetMakeFolder = newTargetFolder
Exit Function
errHandler:
Resume Next
End Function
'---------------------------------------------------'
' These are the Yahoo and/or Google lists '
'---------------------------------------------------'
Private Sub MakeArray(ByRef myArray() As String)
Dim i As Integer
i = 0
ReDim myArray(2, i)
' Most lists taken out for brevity...
i = AddToArray(myArray, "[Sharpen the Saw]", "LinkedinUSMC", "Social-USMC", i)
i = AddToArray(myArray, "The Terran Institute", "space-elevator", "Space-Elevator", i)
End Sub
Private Function AddToArray(ByRef myArray() As String, ByVal pstFolderName As String, ByVal emailName As String, ByVal targetFolders As String, ByVal index As Integer) As Integer
ReDim Preserve myArray(2, index)
myArray(0, index) = pstFolderName
myArray(1, index) = emailName
myArray(2, index) = targetFolders
AddToArray = index + 1
End Function