Outlook 2013 Rules

Hi -

I have a user that would like to have email messages from employees in the company automatically be delivered to a certain folder in Outlook.

For example:
john.smith@abc.com --> gets delivered to  john.smith outlook folder.
or
jack.reed@abc.com --> gets delivered to jack.reed outlook folder

He is creating a new rule for every user, over 300! I would like to create a vba script to run as a rule and only have one rule.

Notes:
-This would only be for abc.com domain
- If abc domain then deliver to users folder
- if the users folder does not exist then create it.

I don't have a lot of experience with vba and outlook(vba) but know visual basic.  Could someone point me in the right direction to work on this code.

Thanks in advance.
doctor069Asked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

doctor069Author Commented:
I was able to check the mail and create a folder if it does not exist with the following code. The only issue I have now is to move the message to the folder

Sub CheckUser(Item As Outlook.MailItem)
 Dim strUser As String
strUser = Item.SenderName
'MsgBox (strUser)

 
 If ResolveDisplayNameToSMTP(strUser) <> "" Then
 'MsgBox (strUser)
     Dim MyFolder As Outlook.MAPIFolder
     If CheckForFolder(strUser) = False Then ' Folder doesn't exist
        Set MyFolder = CreateSubFolder(strUser)
     End If
 End If
End Sub

Function CheckForFolder(strFolder As String) As Boolean
' looks for subfolder of specified folder, returns TRUE if folder exists.
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olInbox As Outlook.MAPIFolder
Dim FolderToCheck As Outlook.MAPIFolder
 
Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olInbox = olNS.GetDefaultFolder(olFolderInbox)
 
' try to set an object reference to specified folder
On Error Resume Next
Set FolderToCheck = olInbox.Folders(strFolder)
On Error GoTo 0
 
If Not FolderToCheck Is Nothing Then
  CheckForFolder = True
End If
 
ExitProc:
Set FolderToCheck = Nothing
Set olInbox = Nothing
Set olNS = Nothing
Set olApp = Nothing
End Function

Function CreateSubFolder(strFolder As String) As Outlook.MAPIFolder
' assumes folder doesn't exist, so only call if calling sub knows that
' the folder doesn't exist; returns a folder object to calling sub
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olInbox As Outlook.MAPIFolder
 
Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olInbox = olNS.GetDefaultFolder(olFolderInbox)
 
Set CreateSubFolder = olInbox.Folders.Add(strFolder)
 
ExitProc:
Set olInbox = Nothing
Set olNS = Nothing
Set olApp = Nothing
End Function

Function ResolveDisplayNameToSMTP(sFromName)
  Dim oRecip As Outlook.Recipient
  Dim oEU As Outlook.ExchangeUser
  Dim oEDL As Outlook.ExchangeDistributionList
 
  Set oRecip = Application.Session.CreateRecipient(sFromName)
  oRecip.Resolve
  If oRecip.Resolved Then
    Select Case oRecip.AddressEntry.AddressEntryUserType
      Case OlAddressEntryUserType.olExchangeUserAddressEntry
        Set oEU = oRecip.AddressEntry.GetExchangeUser
        If Not (oEU Is Nothing) Then
          ResolveDisplayNameToSMTP = oEU.PrimarySmtpAddress
        End If
      Case OlAddressEntryUserType.olOutlookContactAddressEntry
        Set oEU = oRecip.AddressEntry.GetExchangeUser
        If Not (oEU Is Nothing) Then
          ResolveDisplayNameToSMTP = oEU.PrimarySmtpAddress
        End If
      Case OlAddressEntryUserType.olExchangeDistributionListAddressEntry
        Set oEDL = oRecip.AddressEntry.GetExchangeDistributionList
        If Not (oEDL Is Nothing) Then
          ResolveDisplayNameToSMTP = oEU.PrimarySmtpAddress
        End If
    End Select
  End If
End Function  ' ResolveDisplayNameToSMTP
0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Outlook

From novice to tech pro — start learning today.

Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.