Executar regra do Outlook em todas as caixas de correio (Contas)?

Eu tenho mais de 10 contas de email abertas no outlook 2016, tenho algumas regras para coletar todos os emails com assunto específico para uma pasta nas minhas contas de email, o problema aqui é que eu tenho que selecionar todas as caixas de correio e executar a regra em , existe alguma maneira de executar regras em todas as caixas de correio (contas) de uma só vez?

email microsoft-outlook rules

— Mohammad Awni Ali
fonte

Depois de pesquisar na Internet, encontrei o seguinte código VBA que pode executar regras ou regras em todas as contas de email, o código está abaixo:

Sub RunRulesSecondary()

Dim oStores As Outlook.Stores
Dim oStore As Outlook.Store

Dim olRules As Outlook.Rules
Dim myRule As Outlook.Rule
Dim olRuleNames() As Variant
Dim name As Variant

' Enter the names of the rules you want to run
olRuleNames = Array("Rule1")

Set oStores = Application.Session.Stores
For Each oStore In oStores
On Error Resume Next

' use the display name as it appears in the navigation pane
If oStore.DisplayName <> "email@domain.ddns.net" Then

Set olRules = oStore.GetRules()

For Each name In olRuleNames()

    For Each myRule In olRules
       Debug.Print "myrule " & myRule

     If myRule.name = name Then

' inbox belonging to oStore
' need GetfolderPath functionhttp://slipstick.me/4eb2l
        myRule.Execute ShowProgress:=True, Folder:=GetFolderPath(oStore.DisplayName & "\Inbox")

' current folder
'      myRule.Execute ShowProgress:=True, Folder:=Application.ActiveExplorer.CurrentFolder

       End If
    Next
Next

End If
Next
End Sub

Function GetFolderPath(ByVal FolderPath As String) As Outlook.Folder
    Dim oFolder As Outlook.Folder
    Dim FoldersArray As Variant
    Dim i As Integer

    On Error GoTo GetFolderPath_Error
    If Left(FolderPath, 2) = "\\" Then
        FolderPath = Right(FolderPath, Len(FolderPath) - 2)
    End If
    'Convert folderpath to array
    FoldersArray = Split(FolderPath, "\")
    Set oFolder = Application.Session.Folders.Item(FoldersArray(0))
    If Not oFolder Is Nothing Then
        For i = 1 To UBound(FoldersArray, 1)
            Dim SubFolders As Outlook.Folders
            Set SubFolders = oFolder.Folders
            Set oFolder = SubFolders.Item(FoldersArray(i))
            If oFolder Is Nothing Then
                Set GetFolderPath = Nothing
            End If
        Next
    End If
    'Return the oFolder
    Set GetFolderPath = oFolder
    Exit Function

GetFolderPath_Error:
    Set GetFolderPath = Nothing
    Exit Function
End Function

a conta de email email @ domain, é a pasta em que coleto todos os emails por uma regra específica.

— Mohammad Awni Ali
fonte