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

449
Mohammad Awni Ali

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

0

1 ответ на вопрос

0
Mohammad Awni Ali

После поиска в Интернете я нашел следующий код 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 - это папка, в которой я собираю все электронные письма по определенному правилу.