Yey for lunch breaks!
Code:
Option Explicit
Option Base 0
Public Const foldersToSearchNames = "Personal:Companies:Other"
Public Const newFoldersGoHereName = "MISC"
Public Sub IncomingMailMover(mail As Outlook.MailItem)
Dim domain As String
Dim user As String
' is it an active directory string or email?
If InStr(mail.SenderEmailAddress, "@") > 0 Then
user = Split(mail.SenderEmailAddress, "@")(0)
domain = Split(mail.SenderEmailAddress, "@")(1)
Else
' its an active direcotry string, ie.
' "/O=DOMAIN/OU=FIRST ADMINISTRATIVE GROUP/CN=RECIPIENTS/CN=USER.NAME"
Dim chunks, s
chunks = Split(mail.SenderEmailAddress, "/")
For Each s In chunks
If Len(s) > 4 Then
If "O=" = Mid(s, 1, 2) Then
domain = Mid(s, 3)
End If
If "CN=" = Mid(s, 1, 3) Then
user = Mid(s, 4)
End If
End If
Next s
End If
' if domain has any .'s, remove.
If InStr(domain, ".") Then domain = Split(domain, ".")(0)
mail.Move (FindOrMakeFolder(domain))
End Sub
Public Function FindOrMakeFolder(name As String) As MAPIFolder
Dim baseInbox As MAPIFolder, newFoldersHere As MAPIFolder
Dim allowedNames
allowedNames = Split(foldersToSearchNames, ":")
Set baseInbox = Outlook.Application.Session.GetDefaultFolder(olFolderInbox).Parent
Dim f As MAPIFolder, f2 As MAPIFolder
For Each f In baseInbox.Folders
If f.Class = olFolder Then
If ExistInArray(allowedNames, f.name) Then
For Each f2 In f.Folders
If f2.name = name Then
FindOrMakeFolder = f2
GoTo exitfunc
End If
Next f2 ' next sub folder (domain name level)
End If ' is folder we serach
If f.name = newFoldersGoHereName Then Set newFoldersHere = f
End If 'is folder
Next f
' we haven't found folder, make it
If newFoldersHere Is Nothing Then MsgBox "Unable to find new folder path."
FindOrMakeFolder = f.Folders.Add(name, olFolder)
exitfunc:
Dim i
i = 0
End Function
Public Function ExistInArray(ByRef a, search As String) As Boolean
Dim s
ExistInArray = False
For Each s In a
If s = search Then
ExistInArray = True
GoTo exitloop
End If
Next s
exitloop:
End Function