Outlook VBA：Items.Restrict()无法选中全部符合条件邮件的解决咨询

问题现象 #

使用以下VBA宏移动收件箱中符合条件的邮件时，无法一次性处理所有目标邮件：

• 存在2封主题以APPLICATION FOR 开头的邮件时，第一次运行仅移动1封，需再次运行才能处理第二封；
• 存在10封目标邮件时，每次运行仅能处理3-4封，多次运行才能完成全部移动。

原代码 #

Sub Macro1() 'Move e-mail messages from "Inbox" folder to "New Applications"
  Dim olMapi As NameSpace
  Dim olStore As Outlook.Store
  Dim olRootFldr As Outlook.Folder
  Dim olFldrInbox As Outlook.Folder
  Dim olFldrSbmtd As Outlook.Folder
  Dim dateMin As Date, dateMax As Date
  Dim sFilterDmin As String
  Dim sFilterDmax As String
  Dim olItm As Object
  Dim olEmls As Outlook.Items
  Dim olEml As Outlook.MailItem
  Dim nApplications As Integer

  Set olMapi = Application.GetNamespace("MAPI")
  Set olStore = olMapi.Stores("Application Processing Department")
  Set olRootFldr = olStore.GetRootFolder
  Set olFldrInbox = olRootFldr.Folders("Inbox")
  Set olFldrSbmtd = olRootFldr.Folders("Submitted Applications")
  dateMax = Date - 5
  dateMin = dateMax - 2
  sFilterDmin = "[ReceivedTime]>='" & Format(dateMin, "DDDDD HH:NN") & "'"
  sFilterDmax = "[ReceivedTime]<='" & Format(dateMax, "DDDDD HH:NN") & "'"
  Set olEmls = olFldrInbox.Items.Restrict(sFilterDmin)
  If olEmls Is Nothing Then MsgBox "!olEmls1": Exit Sub
  Set olEmls = olEmls.Restrict(sFilterDmax)
  If olEmls Is Nothing Then MsgBox "!olEmls2": Exit Sub
  
  'MsgBox "olEmls.Count=" & olEmls.Count

  nApplications = 0  
  For Each olItm In olEmls
    If TypeOf olItm Is Outlook.MailItem Then
      Set olEml = olItm
      If Not olEml Is Nothing Then
        If Left(UCase(olEml.Subject), 16) = "APPLICATION FOR " Then
          olEml.Move olFldrSbmtd.Folders("New Applications")
          nApplications = nApplications + 1
        End If
        Set olEml = Nothing
      End If
    End If
    DoEvents
  Next olItm
  MsgBox "moved nApplications=" & nApplications
  
End Sub

问题原因 #

核心问题是在For Each遍历Items集合的过程中，执行Move操作会将邮件从原收件箱移除，导致olEmls集合动态变化。For Each循环依赖集合的内部索引，当集合元素被移除时，后续元素的索引会前移，导致循环跳过部分元素，无法遍历全部目标邮件。

解决方法 #

方案1：反向遍历集合（推荐） #

从集合的最后一个元素开始向前遍历，即使前面的元素被移除，也不会影响后续遍历的索引，代码改动最小：

Sub Macro1() 'Move e-mail messages from "Inbox" folder to "New Applications"
  Dim olMapi As NameSpace
  Dim olStore As Outlook.Store
  Dim olRootFldr As Outlook.Folder
  Dim olFldrInbox As Outlook.Folder
  Dim olFldrSbmtd As Outlook.Folder
  Dim dateMin As Date, dateMax As Date
  Dim sFilterDmin As String
  Dim sFilterDmax As String
  Dim olItm As Object
  Dim olEmls As Outlook.Items
  Dim olEml As Outlook.MailItem
  Dim nApplications As Integer
  Dim i As Integer '新增循环索引变量

  Set olMapi = Application.GetNamespace("MAPI")
  Set olStore = olMapi.Stores("Application Processing Department")
  Set olRootFldr = olStore.GetRootFolder
  Set olFldrInbox = olRootFldr.Folders("Inbox")
  Set olFldrSbmtd = olRootFldr.Folders("Submitted Applications")
  dateMax = Date - 5
  dateMin = dateMax - 2
  sFilterDmin = "[ReceivedTime]>='" & Format(dateMin, "DDDDD HH:NN") & "'"
  sFilterDmax = "[ReceivedTime]<='" & Format(dateMax, "DDDDD HH:NN") & "'"
  Set olEmls = olFldrInbox.Items.Restrict(sFilterDmin)
  If olEmls Is Nothing Then MsgBox "!olEmls1": Exit Sub
  Set olEmls = olEmls.Restrict(sFilterDmax)
  If olEmls Is Nothing Then MsgBox "!olEmls2": Exit Sub
  
  'MsgBox "olEmls.Count=" & olEmls.Count

  nApplications = 0  
  '修改为反向遍历
  For i = olEmls.Count To 1 Step -1
    Set olItm = olEmls(i)
    If TypeOf olItm Is Outlook.MailItem Then
      Set olEml = olItm
      If Not olEml Is Nothing Then
        If Left(UCase(olEml.Subject), 16) = "APPLICATION FOR " Then
          olEml.Move olFldrSbmtd.Folders("New Applications")
          nApplications = nApplications + 1
        End If
        Set olEml = Nothing
      End If
    End If
    Set olItm = Nothing
    DoEvents
  Next i
  MsgBox "moved nApplications=" & nApplications
  
End Sub

方案2：先将符合条件的邮件存入静态数组 #

先遍历集合，把所有符合条件的邮件存入静态数组，再遍历数组执行移动操作，彻底避免集合动态变化的影响：

Sub Macro1() 'Move e-mail messages from "Inbox" folder to "New Applications"
  Dim olMapi As NameSpace
  Dim olStore As Outlook.Store
  Dim olRootFldr As Outlook.Folder
  Dim olFldrInbox As Outlook.Folder
  Dim olFldrSbmtd As Outlook.Folder
  Dim dateMin As Date, dateMax As Date
  Dim sFilterDmin As String
  Dim sFilterDmax As String
  Dim olItm As Object
  Dim olEmls As Outlook.Items
  Dim olEml As Outlook.MailItem
  Dim nApplications As Integer
  Dim mailArray() As Outlook.MailItem '静态数组存储目标邮件
  Dim arrIndex As Integer

  Set olMapi = Application.GetNamespace("MAPI")
  Set olStore = olMapi.Stores("Application Processing Department")
  Set olRootFldr = olStore.GetRootFolder
  Set olFldrInbox = olRootFldr.Folders("Inbox")
  Set olFldrSbmtd = olRootFldr.Folders("Submitted Applications")
  dateMax = Date - 5
  dateMin = dateMax - 2
  sFilterDmin = "[ReceivedTime]>='" & Format(dateMin, "DDDDD HH:NN") & "'"
  sFilterDmax = "[ReceivedTime]<='" & Format(dateMax, "DDDDD HH:NN") & "'"
  Set olEmls = olFldrInbox.Items.Restrict(sFilterDmin)
  If olEmls Is Nothing Then MsgBox "!olEmls1": Exit Sub
  Set olEmls = olEmls.Restrict(sFilterDmax)
  If olEmls Is Nothing Then MsgBox "!olEmls2": Exit Sub
  
  'MsgBox "olEmls.Count=" & olEmls.Count

  '先收集所有符合条件的邮件到数组
  ReDim mailArray(1 To olEmls.Count)
  arrIndex = 0
  For Each olItm In olEmls
    If TypeOf olItm Is Outlook.MailItem Then
      Set olEml = olItm
      If Not olEml Is Nothing Then
        If Left(UCase(olEml.Subject), 16) = "APPLICATION FOR " Then
          arrIndex = arrIndex + 1
          Set mailArray(arrIndex) = olEml
        End If
        Set olEml = Nothing
      End If
    End If
    DoEvents
  Next olItm

  '遍历数组执行移动
  nApplications = 0
  For arrIndex = 1 To UBound(mailArray)
    If Not mailArray(arrIndex) Is Nothing Then
      mailArray(arrIndex).Move olFldrSbmtd.Folders("New Applications")
      nApplications = nApplications + 1
      Set mailArray(arrIndex) = Nothing
    End If
  Next arrIndex

  MsgBox "moved nApplications=" & nApplications
  
End Sub

内容的提问来源于stack exchange，提问作者Boba