How to move email to folder based on the sender domain - vba

Question

The attached script on selected emails, create a folder on a non-default PST (OutlookEmail.PST) based on the sender name and move the email to the folder. For e.g MyTest#thisdomain.com, it creates a folder MyTest.
I need advise modifying the script that it creates a folder based on the sender domain for e.g thisdomain.com with subfolder MyTest and then move the email.
This macro is from https://www.slipstick.com/developer/file-messages-senders-name/
Public Sub MoveSelectedMessages()
Dim objOutlook As Outlook.Application
Dim objNamespace As Outlook.NameSpace
Dim objDestFolder As Outlook.MAPIFolder
Dim objSourceFolder As Outlook.Folder
Dim currentExplorer As Explorer
Dim Selection As Selection
Dim obj As Object
Dim objVariant As Variant
Dim lngMovedItems As Long
Dim intCount As Integer
Dim intDateDiff As Integer
Dim strDestFolder As String
Set objOutlook = Application
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set currentExplorer = objOutlook.ActiveExplorer
Set Selection = currentExplorer.Selection
Set objSourceFolder = currentExplorer.CurrentFolder
For Each obj In Selection
Set objVariant = obj
If objVariant.Class = olMail Then
intDateDiff = DateDiff("d", objVariant.SentOn, Now)
' I'm using 40 days, adjust as needed.
If intDateDiff >= 0 Then
sSenderName = objVariant.SentOnBehalfOfName
If sSenderName = ";" Then
sSenderName = objVariant.senderName
End If
On Error Resume Next
' Use These lines if the destination folder is not a subfolder of the current folder
'Dim objInbox As Outlook.MAPIFolder
'Set objInbox = objNamespace.Folders(objDestFolder).Folders("OutlookEmail") ' or whereever the folder is
'Set objDestFolder = objInbox.Folders(sSenderName)
Set objDestFolder = objNamespace.Folders("OutlookEmail").Folders(sSenderName)
'Set objDestFolder = objDestFolder.Folders(sSenderName)
If objDestFolder Is Nothing Then
Set objDestFolder = objNamespace.Folders("OutlookEmail").Folders.Add(sSenderName)
End If
objVariant.Move objDestFolder
'count the # of items moved
lngMovedItems = lngMovedItems + 1
Set objDestFolder = Nothing
End If
End If
Err.Clear
Next
' Display the number of items that were moved.
' MsgBox "Moved " & lngMovedItems & " messages(s)."
Set currentExplorer = Nothing
Set obj = Nothing
Set Selection = Nothing
Set objOutlook = Nothing
Set objNamespace = Nothing
Set objSourceFolder = Nothing
End Sub
A modification that creates the domain but not the subfolder:
If intDateDiff >= 0 Then
sSenderName = Right(objVariant.SenderEmailAddress, Len(objVariant.SenderEmailAddress) - InStr(objVariant.SenderEmailAddress, "#"))

Answer 1

This second version takes into account exchange addresses. No applicable mail available for testing.
Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration
Public Sub MoveSelectedMessages_ExchangeSMTP()
Dim objSenderDomainFolder As folder
Dim strSenderDomain As String
Dim strSenderEmailAddress As String
Dim objDestFolder As folder
Dim strDest As String
Dim Selection As Selection
Dim obj As Object
'Dim intDateDiff As Long
Set Selection = ActiveExplorer.Selection
For Each obj In Selection
If obj.Class = olmail Then
Debug.Print obj.Subject
'intDateDiff = dateDiff("d", obj.SentOn, Now)
'Debug.Print "intDateDiff: " & intDateDiff
'If intDateDiff >= 0 Then ' Not needed for 0
If obj.SenderEmailType = "EX" Then ' exchange
strSenderEmailAddress = obj.Sender.GetExchangeUser().PrimarySmtpAddress
Else ' smtp
strSenderEmailAddress = obj.SenderEmailAddress
End If
Debug.Print "SenderEmailAddress: " & strSenderEmailAddress
strSenderDomain = Right(strSenderEmailAddress, _
Len(strSenderEmailAddress) - InStr(strSenderEmailAddress, "#"))
Debug.Print "strSenderDomain: " & strSenderDomain
strDest = Left(strSenderEmailAddress, InStr(strSenderEmailAddress, "#") - 1)
Debug.Print "strDest: " & strDest
On Error Resume Next
' Bypass error if sSenderDomain folder does not exist, leaving objSenderDomainFolder as Nothing
Set objSenderDomainFolder = Session.folders("OutlookEmail").folders(strSenderDomain)
' Remove error bypass as soon as the purpose is served
On Error GoTo 0
If objSenderDomainFolder Is Nothing Then
Set objSenderDomainFolder = Session.folders("OutlookEmail").folders.Add(strSenderDomain)
End If
If Not objSenderDomainFolder Is Nothing Then
On Error Resume Next
' Bypass error if objDestFolder does not exist, leaving objDestFolder as Nothing
Set objDestFolder = objSenderDomainFolder.folders(strDest)
' Remove error bypass as soon as the purpose is served
On Error GoTo 0
If objDestFolder Is Nothing Then
Set objDestFolder = objSenderDomainFolder.folders.Add(strDest)
End If
obj.Move objDestFolder
End If
' Reset to Nothing for the next iteration of the selection
' Important step due to the use of On Error Resume Next
Set objSenderDomainFolder = Nothing
Set objDestFolder = Nothing
'End If
End If
Next
End Sub
First version. SMTP addresses only.
Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration
Public Sub MoveSelectedMessages()
Dim objSenderDomainFolder As folder
Dim strSenderDomain As String
Dim objDestFolder As folder
Dim strDest As String
Dim Selection As Selection
Dim obj As Object
'Dim intDateDiff As Long
Set Selection = ActiveExplorer.Selection
For Each obj In Selection
If obj.Class = olMail Then
Debug.Print obj.Subject
'intDateDiff = dateDiff("d", obj.SentOn, Now)
'Debug.Print "intDateDiff: " & intDateDiff
'If intDateDiff >= 0 Then ' Not needed for 0
Debug.Print "SenderEmailAddress: " & obj.SenderEmailAddress
strSenderDomain = Right(obj.SenderEmailAddress, _
Len(obj.SenderEmailAddress) - InStr(obj.SenderEmailAddress, "#"))
Debug.Print "strSenderDomain: " & strSenderDomain
strDest = Left(obj.SenderEmailAddress, InStr(obj.SenderEmailAddress, "#") - 1)
Debug.Print "strDest: " & strDest
On Error Resume Next
' Bypass error if sSenderDomain folder does not exist,
' leaving objSenderDomainFolder as Nothing
Set objSenderDomainFolder = _
Session.folders("OutlookEmail").folders(strSenderDomain)
' Remove error bypass as soon as the purpose is served
On Error GoTo 0
If objSenderDomainFolder Is Nothing Then
Set objSenderDomainFolder = _
Session.folders("OutlookEmail").folders.Add(strSenderDomain)
End If
If Not objSenderDomainFolder Is Nothing Then
On Error Resume Next
' Bypass error if objDestFolder does not exist,
' leaving objDestFolder as Nothing
Set objDestFolder = objSenderDomainFolder.folders(strDest)
' Remove error bypass as soon as the purpose is served
On Error GoTo 0
If objDestFolder Is Nothing Then
Set objDestFolder = objSenderDomainFolder.folders.Add(strDest)
End If
obj.Move objDestFolder
End If
' Reset to Nothing for the next iteration of the selection
' Important step due to the use of On Error Resume Next
Set objSenderDomainFolder = Nothing
Set objDestFolder = Nothing
'End If
End If
Next
End Sub

Answer 2

To get the domain name try
DomainName = Mid$(EmailAddress, InStrRev(EmailAddress, "#") + 1, _
InStrRev(EmailAddress, ".") - _
InStrRev(EmailAddress, "#") - 1)
To get the sender name try
SenderName = Left(EmailAddress, InStr(EmailAddress, "#") - 1)