VBA Filter only returning exactly half the restricted criteria items

Question

I am writing some VBA for Outlook, which is not something I often do. I have a strange problem with the following code:

    Sub Archive()
    Dim objSourceFolder As Folder
    Dim OldMessages As Outlook.Items
    Dim Allmessages As Outlook.Items
    Dim objMessage As MailItem
    Dim dtDate As Date
    Dim strDate As String
    Dim strProblemFiles As String
    Dim objTargetFolder As Outlook.MAPIFolder

    'how old is too old? give a number in months
    '-----------------------------------------------
    Const iMonthAge = 6
    '-----------------------------------------------
    strProblemFiles = ""
    'locate the sourcefolder as the inbox
    Set objSourceFolder = Application.Session.GetDefaultFolder(olFolderInbox)

    'locate the target folder as the only one that can work according to IT - they will make this folder consistent apparently
    Set objTargetFolder = Application.Session.Folders.GetFirst
    Set objTargetFolder = objTargetFolder.Folders("Archive")

    'There is this crappy thing on the filtering of messages where it takes a date string, not a date. So we need to calculate and then convert
    'to the format that MS lists on the MSDN site
    dtDate = DateAdd("M", -iMonthAge, Now())
    strDate = Format(dtDate, "ddddd h:nn AMPM")

    'apply a filter to only show messages older than the specified date, which have been read.
    Set Allmessages = objSourceFolder.Items
    Set OldMessages = Allmessages.Restrict("[Received] <= '" & strDate & "' AND [Unread] = False")

'let the poor user know what's going on - they can bail out now if they want
If MsgBox("There are " & OldMessages.Count & " old items to archive. They will be moved from your " & objSourceFolder.Name & _
        " folder to your " & objTargetFolder.Name & " folder.", vbYesNo, "Archive Files Now?") = vbYes Then

    'go through all the messages in the big list of messages older than the specified date, moving them if possible.
    For Each objMessage In OldMessages
        If TypeName(OldMessages.GetFirst) = "MailItem" Then
                'do our shizzle
        Else
                'PRETTY MINIMAL ERROR CATCHING NEEDS IMPROVING
                'write down the name of anything that isn't mail, I guess... need to work on this
                strProblemFiles = strProblemFiles + vbCrLf + objMessage.Subject
                GoTo errorcatch
                'GoTo CarryOn
        End If
            'make a note for anyone who can look
            Debug.Print objMessage.Subject

        If objTargetFolder.DefaultItemType = olMailItem Then
            If objMessage.Class = olMail Then
                    'There's nothing in errorcatch, but there will be
                    On Error GoTo errorcatch
                    'Move the item if you can
                    objMessage.Move objTargetFolder
            End If
        End If
'after an error, we jump here to go to the noxt item
CarryOn:
    Next
Else
        'if the user doesn't want to do it, we need to shut up shop and get the hell out of here
        Set objSourceFolder = Nothing
        Set OldMessages = Nothing
        Set objMessage = Nothing
        Set objTargetFolder = Nothing
        Exit Sub
End If

    'now we have done the whole thing, we can wipe down for fingerprints and exit through the window
    Set objSourceFolder = Nothing
    Set OldMessages = Nothing
    Set objMessage = Nothing
    Set objTargetFolder = Nothing

'reset the errors
On Error GoTo 0
'probably not going to be any that weren't mail items, but didn't cause a real error, but I guess we should show any we skipped.
If strProblemFiles <> "" Then MsgBox strProblemFiles

Exit Sub

'pathetic
errorcatch:
        GoTo CarryOn
End Sub

Function FileExists(FileName As String) As Boolean
    FileExists = (Dir(FileName) <> "")
End Function

Everything works... nearly. the first time I run the macro, it tells me that there are (e.g. 128 items ready to archive. It runs and I notice that there are still old messages in my inbox, so I run it again and it tells me there are 64 items ready for archive... then 32, 16 etc. halving the number of found messages each time. I cannot see why it would do this. Any ideas?

I should mention that this is running on Outlook 2010, using an Exchange.

Thanks for looking - all answers most appreciated!

Cheers, Mark

Answer 1

Something like:

'...
Dim colMove As New Collection
'...
For Each objMessage In OldMessages
    If objTargetFolder.DefaultItemType = olMailItem Then
        If objMessage.Class = olMail Then colMove.Add objMessage
    End If
Next

For Each objMessage In colMove
    objMessage.Move objTargetFolder
Next
'...