Question

我有一个针对VBA的以下Outlook脚本，该脚本应将电子邮件移动到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和isTTYL每个循环是否有特殊原因？您是否尝试过：

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

我已经解决了。您不得在Items循环及其For Each的临时时间使用.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），所以我使用索引。

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

2 个答案: