Script moves only a couple of 'Inbox' items on each execution

Question

I have the follwing VBA script for Outlook that should move emails to the Archives folder (that are not categorized in one of the special categories). It both works and not. I mean it moves some emails but skips the others so I have to run it mulitple times until the Inbox is cleaned-up. I don't understand why it behaves this way. It doesn't throw any exceptions it just doesn't do its job for all items. Can you see anything suspicios here?

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

Possible duplicate of [For Each loop: Not deleting all emails](https://stackoverflow.com/questions/27262798/for-each-loop-not-deleting-all-emails) — niton, Dec 05 '18 at 12:52

score 1 · Answer 1 · answered Dec 05 '18 at 08:42

Not sure whether I miss something here, but your code seems to handle any mail as old, for you set isOld to true within the loop. Is there a special reason for declaring isPinedand isTTYLeach loop? Have you tried:

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

This looks more like a Code Review :-] I don't think that moving variable declarations will fix the issue that this script is not handling all emails in the `Inbox` on each execution. It handles just a couple of them. Sometimes more, sometimes fewer. Or is `VBA` really so _dumb_ that it virtually _distroys_ the local variables and as soon as there is some categorized email it won't process anything after that. This would be terrible! You know what, I'll take your advice and refactor the script, even though it seems to be counterintuitvie... but so is `VBA` ;-) — t3chb0t, Dec 05 '18 at 08:52
True, just changed those parts I could assume to result in problems. Let me know if it works for you :-) — EarlyBird2, Dec 05 '18 at 08:54
I took a couple of old emails and dropped them back to `Inbox` but unfortunatelly I had to execute this version also a couple of times before all items went back to the `Archive` - this seems to have no logic at all :-( — t3chb0t, Dec 05 '18 at 09:03
Busted! Take a look at my [answer](https://stackoverflow.com/a/53629464/235671) ;-) — t3chb0t, Dec 05 '18 at 09:54

score 1 · Answer 2 · answered Dec 05 '18 at 09:53

I've solved it. You must not use Items in a For Each loop and at the samve time .Move its items. It's like modifying the loop collection in C#. The only difference is that C# is throwing a nice exception while VBA just reduces the number of items and then just stops :-o

Instead, I used Do While and two counters. One that counts the processed items and the other that is the current index for Items. Now it processes everything.

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

I tried to copy Items first but I didn't succeed with that (apparently there is no new Outlook.Items) so I use indexes.

Script moves only a couple of 'Inbox' items on each execution

2 Answers2