• Status: Solved
  • Priority: High
  • Security: Public
  • Views: 119
  • Last Modified:

VBA to create a rule for each unique sender in a folder

My company run Exchange server 2016 and Outlook 2016
Some users have have many (hunderds) of folder in their inbox keeped updated manually. I want to automatically create rules to keep their structure updated.

Let me expain with an exemple:

(inbox) exemple@mycompany.com
- Folder Clients
> Sub folder A
>> mail from exemple1@a.com
>> mail from exemple2@a.com
>> mail from exemple1@a.com
> Sub folder B
>> mail from exemple1@b.com
> Sub foldder C
- Folder suppliers


Selecting a folder I want to automatically create rules for all subfolders. In this exemple selecting the root I want to create those rules:
1) move mail from exemple1@a.com or exemple2@a.com to folder clients/A
2) move mail from exemple1@b.com to folder clients/B
1
Giovanni A
Asked:
Giovanni A
1 Solution
 
zvitamConsultantCommented:
VBA is not the right way to implement such rules.

The rules should be on the server side,and I think the right tool for this implementation is Powershell as described in the following atricle:

Managing users’ Outlook rules from Exchange Management Shell (with PowerShell)
0
 
Giovanni ACommented:
Probably I did not explain well my intent.

I have to create a ton of rules for any user. This will take too mouch time both by gui and by powershell. Since All the rule I want to create have the same logic I want to automate their creation.

Theorically I also can create a script that generates the powershell command and then execute them by powershell. I think is more difficult but is also ok if you can help me in that.

Let me expain with an exemple:

inbox exemple@mycompany.com
folders
- Clients
> A
>> mail from exemple1@a.com
>> mail from exemple2@a.com
>> mail from exemple1@a.com
> B
>> mail from exemple1@b.com
> C
- suppliers


I want to automatically create those rules:
1) move mail from exemple1@a.com or exemple2@a.com to folder clients/A
2) move mail from exemple1@b.com to folder clients/B
0
 
Giovanni ACommented:
Please also consider that with outlook 2016 and exchange 2016 I expect client side rules compatible with exchange server (like the described ones)  to automatically move to exchange. This works in my tests
0
 
Giovanni AAuthor Commented:
I updated the request. I hope it is more easy to understand what I need
0
 
Neil FlemingConsultant and developerCommented:
Hi Giovanni: try this:

There are two procedures below. Basically the first runs through your inbox and calls the second, which looks in subfolders for instances of a username. If it finds a target folder, it moves all emails from that person to the subfolder found.

You could also create a userform that pops up and tracks what is going on. But this wokrs fine without such a form.

You just have to call "Distribute2Folders". That uses the second procedure "FindFolder" to find your folders.

Sub Distribute2Folders()
Dim ff As Outlook.Folder, fInbox As Outlook.Folder
Dim oItems As Items, oThis As MailItem
Dim i As Long
Dim sEmail As String

'get inbox
Set fInbox = Session.GetDefaultFolder(olFolderInbox)
Set oItems = fInbox.Items
'sort inbox items by email address, in reverse
oItems.Sort "SenderEmailAddress", True
'move backwards through list
i = oItems.Count
Do
    'only handle mail items
    If TypeName(oItems(i)) = "MailItem" Then
    Set oThis = oItems(i)
        'if email address is different from previous:
        If oThis.SenderEmailAddress <> sEmail Then
        sEmail = oThis.SenderEmailAddress
        'hunt for folder, using FindFolder function below
        Set ff = FindFolder(fInbox, sEmail)
        End If
        'if folder exists, move email item
        If Not (ff Is Nothing) Then
        Debug.Print "Moving: " & oThis.SenderEmailAddress
        oThis.Move ff
        DoEvents
        End If
    End If
i = i - 1
'repeat until all inbox covered
Loop Until (i = 0)
End Sub


Function FindFolder(fCheck As Outlook.Folder, sEmail As String) As Outlook.Folder
Dim ff As Outlook.Folder
Dim oItems As Items, oCheck As MailItem
Set FindFolder = Nothing
'loop through folders:
For Each ff In fCheck.Folders
Set oItems = ff.Items
'check for target email address in folder:
Set oCheck = oItems.Find("[SenderEmailAddress] = '" & sEmail & "'")
    If Not (oCheck Is Nothing) Then
    'if found, set this folder to the target folder
    Set FindFolder = ff
    Exit Function
    Else
    'if not found, keep searching in subfolders of subfolders:
    Set FindFolder = FindFolder(ff, sEmail)
        If Not (FindFolder Is Nothing) Then
        Exit Function
        End If
    End If
Next

End Function

Open in new window

0
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.

Join & Write a Comment

Featured Post

Cloud Class® Course: Microsoft Office 2010

This course will introduce you to the interfaces and features of Microsoft Office 2010 Word, Excel, PowerPoint, Outlook, and Access. You will learn about the features that are shared between all products in the Office suite, as well as the new features that are product specific.

Tackle projects and never again get stuck behind a technical roadblock.
Join Now