Запустить правило outlook для всех почтовых ящиков (учетных записей)?

Question

У меня более 10 учетных записей электронной почты, открытых в outlook 2016, у меня есть какое-то правило, чтобы собирать все электронные письма с определенной тематикой папки в одной из моих учетных записей электронной почты, проблема здесь в том, что я должен выбрать каждый почтовый ящик и затем запустить правило это какой-нибудь способ запустить правило на всех почтовых ящиках (аккаунтах) сразу?

Answer 1

После поиска в Интернете я нашел следующий код VBA, который может запускать правило или правила для всех учетных записей электронной почты, код приведен ниже:

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

учетная запись электронной почты email @ domain - это папка, в которой я собираю все электронные письма по определенному правилу.