我在Outlook 2016中打开了10个以上的电子邮件帐户,我有一些规则来收集所有特定主题的电子邮件到我的邮件帐户中的一个文件夹中,这里的问题是我必须选择每个邮箱,然后从中运行规则,他们有什么办法一次在所有邮箱(帐户)上运行规则吗?
搜索互联网后,我发现以下可以在所有电子邮件帐户上运行一个或多个规则的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 protected]" 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,是我根据特定规则收集所有电子邮件的文件夹。
本文收集自互联网,转载请注明来源。
如有侵权,请联系 [email protected] 删除。
我来说两句