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

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

0 голосов
/ 05 декабря 2018

У меня есть следующий скрипт 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

Ответы [ 2 ]

0 голосов
/ 05 декабря 2018

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

0 голосов
/ 05 декабря 2018

Не уверен, что я что-то здесь упускаю, но ваш код, кажется, обрабатывает любую почту как старую, поскольку вы устанавливаете 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
...