Скрипт перемещает только пару элементов «Входящие» при каждом выполнении

У меня есть следующий скрипт 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("[email protected]").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

outlook vba outlook-2016
person t3chb0t    schedule 05.12.2018    source источник
comment
Возможный дубликат Для каждого цикла: не удалять все электронные письма   -  person niton    schedule 05.12.2018

Ответы (2)


arrow_upward
1
arrow_downward

Не уверен, что я что-то здесь упустил, но ваш код, похоже, обрабатывает любую почту как старую, потому что вы устанавливаете isOld в значение true внутри цикла. Есть ли особая причина для объявления цикла isPinedand 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("[email protected]").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
person EarlyBird2    schedule 05.12.2018
comment
Это больше похоже на обзор кода :-] Я не думаю, что перемещение объявлений переменных решит проблему, заключающуюся в том, что этот скрипт не обрабатывает все электронные письма в Inbox при каждом выполнении. Он обрабатывает только пару из них. Иногда больше, иногда меньше. Или VBA действительно настолько тупой, что фактически уничтожает локальные переменные, и как только появляется какая-то категоризированная электронная почта, после этого она ничего не обрабатывает. Это было бы ужасно! Знаешь что, я последую твоему совету и рефакторинг скрипта, хоть это и кажется нелогичным... но так оно и есть VBA ;-) - person t3chb0t; 05.12.2018
comment
Правда, просто поменял те детали, которые, как я мог предположить, приведут к проблемам. Дайте мне знать, если это работает для вас :-) - person EarlyBird2; 05.12.2018
comment
Я взял пару старых писем и перекинул их обратно в Inbox, но, к сожалению, мне пришлось запустить и эту версию пару раз, прежде чем все элементы вернулись в Archive — в этом, похоже, нет никакой логики :-( - person t3chb0t; 05.12.2018
comment
Разорили! Взгляните на мой ответ ;-) - person t3chb0t; 05.12.2018

arrow_upward
1
arrow_downward

Я решил это. Вы не должны использовать 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 нет), поэтому я использую индексы.

person t3chb0t    schedule 05.12.2018