Handling Outlook Mail in VBA for Outlook

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