Outlook VBA for creating a message domain field and distills to and from to those fields.

Creates domain.from and domain.to user fields which can be used to group and sort. Step 1 of a larger plan to organize email. This makes cleaning up your mailboxes a snap! Also adds the user defined field in the view. 
Macros have to be on and it has to be trusted.
You can run this on an individual message (alt+F8) will bring up the menu to run 
Set_Domains_Current_Message
or
Set_Domains_for_all_messages_active_folder

The second routine asks if you want to override current definitions. Click NO to make it faster on a re-run.

I also have a thisoutlook session which automatically processess each message as it comes in. Will post that next.

Paste this into a module in outlook VBA- if you don't know how- I might be able to help by posting instructions here.

Code goes in a module named "MyDomains"
-----Code below this line-------------------------------------------------------------------------


Option Explicit
'---------------------------------------
'2014-02-06-added support for missed conversations
Public Const VERSION = "2014.02.06.01.02"
Public Const USER_DOM_TO = "TO.Domain"
Public Const USER_DOM_FROM = "FROM.Domain"
Const VBQT = """"
Private DebugTime As Date
Public StartTime As Date

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''--REFERENCE CODE TO CALL FROM OUTLOOK MACROS-----------------------------------------------------------
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub Set_Domains_for_all_messages_active_folder()
   Dim ObjFolders As Items
   Dim ForceReset As Boolean
   Set ObjFolders = Outlook.ActiveExplorer.CurrentFolder.Items.Restrict("[Message Class] = 'IPM.note'")
   ForceReset = (MsgBox("Force reset of to/from domain definitions?", vbYesNo, "Domain to/from") = vbYes)
   Set_Domains_Mail_Collection ObjFolders, ForceReset
   
    VIEW_ADD_COLUMN (USER_DOM_FROM)
    
End Sub

Sub Set_Domains_Current_Message()
   Dim objSel As Selection
   Dim ForceReset As Boolean
   Dim i As Integer
   Dim objMail As MailItem
   
   Set objSel = Outlook.ActiveExplorer.Selection
   ForceReset = True ''(MsgBox("Force reset of to/from domain definitions?", vbYesNo, "Domain to/from") = vbYes)
   frmProgress.SetMax (objSel.Count)
   For i = 1 To objSel.Count
      DoEvents
      frmProgress.SetCurrent (i)
      SetDomainMailObject objSel.item(i), True
   Next i
   
   VIEW_ADD_COLUMN (USER_DOM_FROM)
   
End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''------------------ACTIVE CODE--------------------------------------------------------------------------
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub SetDomainMailObject(objObject As Object, Optional ForceReset As Boolean)
 ''takes any object and uses the properties of the defined objects to set the domain info
 ''subroutine to determine type of message an run appropriate component to
 ''get domain informaion
 Dim objMail As MailItem
   Select Case TypeName(objObject)
      Case "MailItem"
         Set objMail = objObject
         If Not (objMail.Subject Like "Missed conversation with*") And Not (objMail.Sender Is Nothing) Then
            ''check if sent on behalf of and use that email address
            If InStr(1, "@", objMail.SenderEmailAddress) > 0 Then
               Set_UserProperty objMail, USER_DOM_FROM, Get_DomainSMTPAddress(objMail.SenderEmailAddress), ForceReset
            Else
               Set_UserProperty objMail, USER_DOM_FROM, Get_Domain(objMail.Sender), ForceReset
            End If
            Set_UserProperty objMail, USER_DOM_TO, Get_Domain(objMail.recipients), ForceReset
         Else
            Set_UserProperty objObject, USER_DOM_FROM, Get_DomainSMTPAddress(objObject.SenderEmailAddress), ForceReset
            Set_UserProperty objObject, USER_DOM_TO, Get_Domain(objObject.recipients), ForceReset
         ''is lync conversation leftover
         End If
      Case "MeetingItem"
         Stop ''need code''''''''''''''<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
      Case Else
   End Select
End Sub

Public Sub Set_UserProperty(ByRef objmsg As MailItem, UserPropertyID As String, UserPropertyValue As String, Optional Reset As Boolean)
'PROGRESS.SubTitleUpdate "Set From Domain"
    Dim objProp As UserProperty
    
    ' Check if the item already has a Domain Property,
    ' Get a pointer to the new or existing one
    If Reset Or objmsg.UserProperties(UserPropertyID) Is Nothing Then
      Set objProp = objmsg.UserProperties.Add(UserPropertyID, olText)
    Else
      Set objProp = objmsg.UserProperties(UserPropertyID)
    End If
   
    ' If the Item is a mail item, Get the domain, else Report that it isn't a mail item
    If olMail = objmsg.Class Then
      ''objProp.Value = GetFromDomain(str)
      objProp.value = UserPropertyValue
    Else
      objProp.value = "Not a Mail Item"
    End If
           
    objmsg.Save

End Sub


Public Sub get_UserProperty(ByRef objmsg As MailItem, UserPropertyID As String, Optional Reset As Boolean)
'PROGRESS.SubTitleUpdate "Set From Domain"
    Dim objProp As UserProperty
    Stop  '''fix to get not set
  '''''''''''''''''''''''''<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
    ' Check if the item already has a Domain Property,
    ' Get a pointer to the new or existing one
    If Reset Or objmsg.UserProperties(UserPropertyID) Is Nothing Then
      Set objProp = objmsg.UserProperties.Add(UserPropertyID, olText)
    Else
      Set objProp = objmsg.UserProperties(UserPropertyID)
    End If
   
    ' If the Item is a mail item, Get the domain, else Report that it isn't a mail item
    If olMail = objmsg.Class Then
      ''objProp.Value = GetFromDomain(str)
      'objProp.Value = UserPropertyValue
    Else
      objProp.value = "Not a Mail Item"
    End If
           
    objmsg.Save

End Sub

Private Sub Set_Domains_Mail_Collection(ByRef Mail_Items As Items, Optional ForceReset As Boolean)
'PROGRESS.SubTitleUpdate "Set_Domains_Mail_Collection"
    '''Export path
    'Dim ExPath As String
    '''''''''''''''''''''''''''''''''''''''
    ''when setting direct folder to export
    Dim objMail As MailItem

    Dim i As Integer
    Dim objProp As UserProperty
      
    StartTime = Time ''for debug
    On Error GoTo 0
    frmProgress.SetMax (Mail_Items.Count)
    'On Error Resume Next 'GoTo Set_Domains_Mail_Collection_ERR
    For i = 1 To Mail_Items.Count
      DoEvents
      
      SetDomainMailObject Mail_Items.item(i)
      
      frmProgress.SetCurrent (i)
      debugx  '''<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
    Next i

GoTo ExportEmailCLEANUP:

''error trap
Set_Domains_Mail_Collection_ERR:
MsgBox Err.description
'Stop
Resume

ExportEmailCLEANUP:
    On Error Resume Next
        Set Mail_Items = Nothing
        Set objMail = Nothing
        Set Mail_Items = Nothing
    On Error GoTo 0
    
frmProgress.Hide

End Sub

'''''''''''''''''''''
''''''''''''''''''''''''
Private Function Get_Domain(ByRef Addr_or_Recips As Object, Optional ReturnExchangeGroups As Boolean) As String
''If ReturnExchangeGroups then the local address exchange server group will be returned,
''othewise the local domain will be returned for exchange addresses.
   'Dim MyAtPos As Integer
   Dim ii
   Dim strOU As String
   Dim xaddr As String
   Dim rec
   
   Dim colDom As New Collection
   If IsMissing(ReturnExchangeGroups) Then ReturnExchangeGroups = False
   On Error Resume Next
   Get_Domain = ""
   
   ''check type name for rec, if an address entry was passed it has to be a collection to work properly below)
   If TypeName(Addr_or_Recips) = "AddressEntry" Then
      Dim X As New Collection
      X.Add Addr_or_Recips
      Set rec = X
      Set X = Nothing
   Else
      Set rec = Addr_or_Recips
   End If

Get_Domain_isCollection:
   For ii = 1 To rec.Count
      If "SMTP" = Left(UCase(rec.item(ii).Address), 4) _
      Or InStr(1, rec.item(ii).Address, "@", vbTextCompare) > 0 _
      Then
         Get_Domain = Get_Domain & Get_DomainSMTPAddress(rec.item(ii).Address) & "; "
      Else
         If ReturnExchangeGroups Then
            ' Strip out the Domain from the mail using LDAP format. e.g. /o=LatentZero/ou=Adm..... Strip out LatentZero
            strOU = Left(rec.item(ii).Address, InStr(1, rec.item(ii).Address, "/ou=", vbTextCompare) - 1)
            Get_Domain = Get_Domain & Mid(strOU, 4) & "; "
         Else
            Get_Domain = Get_Domain & Get_DomainExchangeAddress(rec.item(ii)) & ";"
         End If
      End If
      ''else try adding GetToDomainCDO???
   Next ii
  
   Get_Domain = Simplify_List(Get_Domain, ";")
   
End Function
Private Function Get_DomainSMTPAddress(Address As String) As String
Dim MyAtPos As Integer

   MyAtPos = InStr(1, Address, "@", vbTextCompare) + 1
   Get_DomainSMTPAddress = UCase(REDUCE_DOMAINS(Mid(Address, MyAtPos)))
   
End Function
Private Function Get_DomainExchangeAddress(ObjRecipient As Object)
''http://msdn.microsoft.com/en-us/library/office/ff868695.aspx
''How to: Obtain the E-mail Address of a Recipient from outlook address entry
Dim MyAtPos As Integer ''find @
   Get_DomainExchangeAddress = ObjRecipient.PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x39FE001E")
   MyAtPos = InStr(1, Get_DomainExchangeAddress, "@", vbTextCompare) + 1
   Get_DomainExchangeAddress = Mid(Get_DomainExchangeAddress, MyAtPos)
End Function

Private Function Simplify_List(ByRef List As String, Delimeter As String) As String
   'PROGRESS.SubTitleUpdate "Simplify List"
   If Delimeter = "" Then Delimeter = ","
   
   Dim X, i, ii
   Dim uX As Integer
   Dim temp As String
   
   X = Split(UCase(List), Delimeter)
   uX = UBound(X)
   
   For i = 0 To uX
      X(i) = REDUCE_DOMAINS(Trim(X(i)))   '<<<<
   Next i
   
   ''sort
   For i = uX To 1 Step -1
      For ii = i - 1 To 0 Step -1
         If X(i) < X(ii) Then
         temp = X(i)
         X(i) = X(ii)
         X(ii) = temp
         End If
      Next ii
   Next i
   
   ''DE-DUPE
   For i = uX To 1 Step -1
      For ii = i - 1 To 0 Step -1
         If X(i) = X(ii) Then
            X(i) = ""
            Exit For
         End If
      Next ii
   Next i
   
   List = ""
   
   For i = 0 To uX
      If X(i) > "" Then List = List & Trim(X(i)) & Delimeter '& " "
   Next i
   
   Simplify_List = Left(List, Len(List) - Len(Delimeter))
End Function

Private Function REDUCE_DOMAINS(Name As String, Optional Delim As String, Optional level As Integer) As String
   ''specify level of granularity for domain
   ''ie car.foo.com level 2 = foo.com
   If level = 0 Then level = 2
   If Delim = "" Then Delim = "."
   If Name = "" Then Exit Function
   
   Dim X
   X = Split(Name, Delim)
   Dim i As Integer
   
   level = level - 1 ''adjust base 0
   If level > UBound(X) Then
   REDUCE_DOMAINS = Name
   End If
   REDUCE_DOMAINS = ""
   For i = UBound(X) - level To UBound(X)
      REDUCE_DOMAINS = REDUCE_DOMAINS & X(i) & Delim
   Next i
   REDUCE_DOMAINS = Left(REDUCE_DOMAINS, Len(REDUCE_DOMAINS) - 1)
End Function


Private Sub debugx()
''set to stop and debug every xx seconds...
If DebugTime = 0 Then DebugTime = Date + Time + 30 / 60 / 60 / 24
If DebugTime < Date + Time Then
    'Stop
    DebugTime = Date + Time + 30 / 60 / 60 / 24
End If
End Sub
Private Sub VIEW_ADD_COLUMN(ByVal strField As String)
   Dim ns As Outlook.NameSpace
   Dim fld As Outlook.Folder
   Dim vw As Outlook.TableView
   Dim vwf As Outlook.ViewField
   Dim udf As Outlook.UserDefinedProperty
   Dim udfName As String
   
   Set ns = Application.Session
   Set fld = Outlook.ActiveExplorer.CurrentFolder
   
   If fld Is Nothing Then
      fld = ns.GetDefaultFolder(Outlook.OlDefaultFolders.olFolderInbox)
   End If
   
   Set vw = fld.CurrentView
   
   Set udf = fld.UserDefinedProperties.Find(strField)
   
   If udf Is Nothing Then
      Set udf = fld.UserDefinedProperties.Add(strField, Outlook.OlUserPropertyType.olText, _
      Outlook.OlFormatText.olFormatTextText, "")
      
      udfName = _
      "http://schemas.microsoft.com/mapi/string/{00020329-0000-0000-C000-000000000046}/" & strField   ''no spaces replace spaces with %20  .Replace(" ", "%20")
      Set vwf = vw.ViewFields.Insert(udfName, vw.ViewFields.Count)
      Set vwf = vw.ViewFields.item(udfName)
      
   Else
      ''try
      On Error Resume Next
      Set vwf = vw.ViewFields(udf.Name)
      
      ''Catch ex As System.Runtime.InteropServices.COMException
      ''End Try
   
      If vwf Is Nothing Then
         vwf = vw.ViewFields.Insert(udf.Name, 1)
         vwf.ColumnFormat.Width = 60
      Else
         vwf.ColumnFormat.Width = 60
      End If
      
      vw.Save
      vw.Apply
      
   End If

End Sub