Question

尝试运行一个简单的规则，以将到达的电子邮件从第一公共电子邮件箱移动到第二公共电子邮件箱（规则是：消息到达后应用此规则|发送到“第一公共电子邮件箱” |将其移动到“第二个公共电子邮件箱”文件夹）。手动运行时，该规则有效，但在收到电子邮件后该规则不会自动起作用（研究表明可能存在一些损坏的文件，等等）。试图使其通过VBA代替。下面的宏应该在弹出提示时运行规则。提示会弹出，但规则不会运行。通过QAT自定义按钮运行该宏，将显示进度窗口，该窗口显示进度，但是电子邮件仍位于第一个公共电子邮件框中。

Private Sub Application_Reminder(ByVal Item As Object)

If Item.MessageClass <> "IPM.Task" Then
  Exit Sub
End If

If Item.Subject = "Run Rules" Then
  RunRules
End If

End Sub

Sub RunRules()

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

olRuleNames = Array("Rule A", "Rule B")

Set olRules = Application.Session.DefaultStore.GetRules()

For Each name In olRuleNames()
    For Each myRule In olRules
    ' Rules we want to run
        If myRule.name = name Then
        myRule.Execute ShowProgress:=True
        End If
    Next
Next
End Sub

Answer 1

DefaultStore的使用是对默认存储以外的存储的提示。

Set olRules = Application.Session.DefaultStore.GetRules()

Option Explicit

Private Sub FindStoreWithRules()

Dim colStores As stores
Dim oStore As store

Dim olRules As rules
Dim myRule As Rule

Dim i As Long

Set colStores = Session.stores

For i = 1 To colStores.count

    Debug.Print i & ": " & colStores(i)

    ' On second run
    ' Enter applicable name then uncomment this line and the End If
    ' If colStores(i) = "Name of store shown in immediate window" Then

        On Error Resume Next
        ' Where rules not applicable on some stores there is an error.
        Set olRules = colStores(i).GetRules()
        ' Discontinue error bypass as soon as the purpose is served
        On Error GoTo 0

        If Not olRules Is Nothing Then
            For Each myRule In olRules
                ' Uncomment on second run to see if what rules were found
                'Debug.Print " - " & myRule.name
            Next
        Else
            Debug.Print "Rules not applicable in " & colStores(i)
        End If

    ' End If

Next

Debug.Print "Done."

End Sub

Outlook 2016 VBA可按计划自动运行规则

1 个答案: