脚本在每次执行时只移动几个“收件箱”项目

Question

我有 Outlook 的以下 VBA 脚本，它应该将电子邮件移动到 Archives 文件夹（未归类为特殊类别之一）。它既有效又无效。我的意思是它会移动 一些 电子邮件，但会跳过其他电子邮件，因此我必须多次运行它，直到 Inbox 被清理干净。我不明白为什么它会这样。它不会抛出任何异常，只是不会为所有项目完成工作。你能看出这里有什么可疑之处吗？

Option Explicit

Sub CleanUpInbox()

    Dim ns As Outlook.NameSpace
    Set ns = GetNamespace("MAPI")
    Dim inbox As Outlook.Folder: Set inbox = ns.GetDefaultFolder(olFolderInbox)
    Dim archive As Outlook.Folder: Set archive = ns.Folders("my@mailbox.abc").Folders("Archives").Folders("2018")

    Dim maxDiffInDays As Integer: maxDiffInDays = 14
    Dim today As Date: today = DateValue(now())

    On Error GoTo bang

    Dim mail As Variant ' Outlook.MailItem
    For Each mail In inbox.Items

        If mail Is Nothing Then
            GoTo continue
        End If

        Dim receivedOn As Date: receivedOn = DateValue(mail.ReceivedTime)
        Dim diff  As Integer: diff = DateDiff("d", receivedOn, today)
        Dim isOld As Boolean: isOld = True ' diff > maxDiffInDays
        If isOld Then

            'Debug.Print diff
            'Debug.Print mail.Subject
            'Debug.Print mail.Categories

            Dim isPinned As Boolean: isPinned = InStr(mail.Categories, "PINNED")
            Dim isTTYL As Boolean: isTTYL = InStr(mail.Categories, "TTYL")

            If LinqAll(False, isPinned, isTTYL) Then
                Debug.Print mail.Subject
                mail.Move archive
            End If

        End If


GoTo continue

bang:

        Debug.Print "bang!"
        Debug.Print Err.Description

continue:

    Next

End Sub

Function LinqAll(ByVal Expected As Boolean, ParamArray Values() As Variant) As Boolean

    Dim x As Variant
    For Each x In Values
        If x <> Expected Then
            LinqAll = False
            Exit Function
        End If
    Next
    LinqAll = True

End Function

Function LinqAny(ByVal Expected As Boolean, ParamArray Values() As Variant) As Boolean

    Dim x As Variant
    For Each x In Values
        If x = Expected Then
            LinqAny = True
            Exit Function
        End If
    Next
    LinqAny = False

End Function

Answer 1

不确定我是否在这里遗漏了什么，但您的代码似乎可以处理任何旧邮件，因为您在循环中将 isOld 设置为 true。声明isPined和isTTYLeach 循环是否有特殊原因？你试过了吗：

Sub CleanUpInbox()

Dim ns As Outlook.Namespace
Dim inbox As Outlook.Folder: Set inbox = ns.GetDefaultFolder(olFolderInbox)
Dim archive As Outlook.Folder: Set archive = ns.Folders("my@mailbox.abc").Folders("Archives").Folders("2018")
Dim maxDiffInDays As Integer: maxDiffInDays = 14
Dim today As Date: today = DateValue(Now())
Dim mail As Variant ' Outlook.MailItem
Dim receivedOn As Date
Dim diff  As Integer
Dim isOld As Boolean
Dim isPinned As Boolean
Dim isTTYL As Boolean

Set ns = GetNamespace("MAPI")
On Error GoTo bang

For Each mail In inbox.Items

    If mail Is Nothing Then
        GoTo continue
    End If

    isOld = False
    receivedOn = DateValue(mail.ReceivedTime)
    diff = DateDiff("d", receivedOn, today)

    If diff > maxDiffInDays Then
        isOld = True
    End If
    isPinned = InStr(mail.Categories, "PINNED")
    isTTYL = InStr(mail.Categories, "TTYL")

    If LinqAll(False, isPinned, isTTYL) Then
        Debug.Print mail.Subject
        mail.Move archive
    End If

    GoTo continue

bang:
    Debug.Print "bang!"
    Debug.Print Err.Description

continue:
Next

End Sub

Answer 2

我已经解决了。您不得在 For Each 循环中使用 Items 并同时在 .Move 其项目中使用。这就像修改C# 中的循环集合一样。唯一的区别是C# 抛出了一个很好的异常，而VBA 只是减少了项目的数量然后就停止了：-o

相反，我使用了Do While 和两个计数器。一个计算已处理的项目，另一个是Items 的当前索引。现在它处理一切。

Sub CleanUpInbox2()

    ' ... other variables

    Dim processCount As Integer
    Dim itemIndex As Integer: itemIndex = 1
    Dim itemCount As Integer: itemCount = inbox.Items.Count
    Do While processCount < itemCount

        processCount = processCount + 1

        Set mail = inbox.Items(itemIndex)

        ' ... body

        If LinqAll(False, isPinned, isTTYL) Then
            Debug.Print mail.Subject
            mail.Move archive
            moveCount = moveCount + 1
        Else
            itemIndex = itemIndex + 1
        End If

bang:
        Debug.Print "bang!"
        Debug.Print Err.Description

continue:

    Loop

    Debug.Print "Emails processed: " & processCount
    Debug.Print "Emails moved: " & moveCount

End Sub

我尝试先复制Items，但没有成功（显然没有new Outlook.Items）所以我使用索引。