Handling Outlook Mail in VBA for Outlook

StarPilot — Fri, 12 Oct 2007 17:55:00 GMT

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

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

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

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

Cross posted from my blog at http://schema.sol3.net/kbarrows

Keith Barrows : Outlook

Handling Outlook Mail in VBA for Outlook