Looping through unread emails, changing unread to read, using For Each

Question

I wrote code to pick up unread email and with other criteria.

The code runs but For Each itm In olFolder.Items.Restrict(sFilter) is not working.

For example if there are 4 unread emails in the inbox the For Each should loop 4 times but the loop is happening only 2 times.

Sub ReadOutlookEmails_WithCriteria()
    Dim olApp As Outlook.Application, olNs As Outlook.Namespace
    Dim olFolder As Outlook.MAPIFolder, olMail As Outlook.MailItem
    Dim eFolder As Outlook.Folder '~~> additional declaration
      Dim Inbox As Outlook.MAPIFolder
    Dim SubFolder As Outlook.MAPIFolder
    Dim objAtt As Outlook.Attachment
        Dim olItem As Outlook.MailItem
    Dim olReply As MailItem ' Reply
    Dim olRecip As Recipient
    Dim i As Long
    Dim x As Date, ws As Worksheet '~~> declare WS variable instead
    Dim lrow As Long '~~> additional declaration

    Set ws = ActiveSheet '~~> or you can be more explicit using the next line
    Set EC = ThisWorkbook.Sheets("Email Search Criteria")
    Set IE = ThisWorkbook.Sheets("Inbox Emails")
    Set olApp = New Outlook.Application
    Set olNs = olApp.GetNamespace("MAPI")
    Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
    Set SubFolder = Inbox.Folders("Rejected Emails")
    
    Todays_Date = EC.Range("E2").Value
    
    IE.Rows("2:10000").Clear
    Incr = 2

    For Each eFolder In olNs.GetDefaultFolder(olFolderInbox).Folders
        If eFolder = "Mandatory Training Enrollment" Then 'IF_Check_1
            Set olFolder = olNs.GetDefaultFolder(olFolderInbox).Folders(eFolder.Name): Debug.Print olFolder
            
            sFilter = "[ReceivedTime] >= '" & Todays_Date & "' AND [UNREAD]=TRUE"
            Debug.Print olFolder.Items.Restrict(sFilter).Count
            
            '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
            For Each itm In olFolder.Items.Restrict(sFilter) ''''Problem is over here
            '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
            
                If itm.Attachments.Count = EC.Range("B2") Then  'itm Like "*" & EC.Range("A2") & "*" And'IF_Check_2
                   For Each objAtt In itm.Attachments
                        Debug.Print "Subject Name - " & itm: Debug.Print "Attachment Type - " & objAtt.DisplayName
                        Debug.Print "Attachment Size - " & objAtt.Size: Debug.Print "Attachments Count - " & objAtt.Index
                        
                        Debug.Print "Subject Name - " & EC.Range("A2"): Debug.Print "Attachment Type - " & EC.Range("C2")
                        Debug.Print "Attachment Size - " & EC.Range("D2"): Debug.Print "Attachments Count - " & EC.Range("B2")
                        
                        If objAtt.Size <= EC.Range("D2") And UCase(objAtt.Filename) Like UCase("*" & EC.Range("C2")) Then
                                IE.Range("A" & Incr) = olFolder
                                IE.Range("B" & Incr) = itm.SenderName
                                IE.Range("C" & Incr) = itm
                                IE.Range("D" & Incr) = objAtt.DisplayName
                                IE.Range("E" & Incr) = itm.Attachments.Count
                                IE.Range("F" & Incr) = objAtt.Size
                                IE.Range("G" & Incr) = "Pass"
                                
                                Set olReply = itm.ReplyAll
                                'Set olRecip = olReply.Recipients.Add("Email Address Here") ' Recipient Address
                                'olRecip.Type = olCC
                                olReply.Body = "Hello," & vbNewLine & vbNewLine & "Email Success" & vbNewLine & vbNewLine & "Thank you. " & vbCrLf & olReply.Body
                                olReply.Display
                                'olReply.SentOnBehalfOfName = onBehalfOf
                                'olReply.SendUsingAccount = getGenericMailboxAccount(onBehalfOf)
                                
                                olReply.Send
                                
                                itm.UnRead = False
                                
                        End If
                   Next objAtt
                ElseIf itm.Attachments.Count <> EC.Range("B2") Then 'IF_Check_2

                            FailReason1 = "Attament is not a PDF"
                            FailReason2 = "Attachment size is more than 10MB"
                            FailReason3 = "Attachment is missing with email"
                            FailReason4 = "Attachments are more than 1"
                            
                            IE.Range("A" & Incr) = olFolder
                            IE.Range("B" & Incr) = itm.SenderName
                            IE.Range("C" & Incr) = itm
                            IE.Range("D" & Incr) = ""
                            IE.Range("E" & Incr) = itm.Attachments.Count
                            IE.Range("F" & Incr) = ""
                            IE.Range("G" & Incr) = "Fail"
                            
                            EBody = "Hello," & vbNewLine & vbNewLine & "Email Not Success." & vbNewLine & vbNewLine _
                                & "Fail Reason Might Be One Of The Below Mentioned:" & vbNewLine & vbNewLine _
                                & "*" & FailReason1 & vbNewLine & vbNewLine _
                                & "*" & FailReason2 & vbNewLine & vbNewLine _
                                & "*" & FailReason3 & vbNewLine & vbNewLine _
                                & "*" & FailReason4 & vbNewLine & vbNewLine _

                            Set olReply = itm.ReplyAll
                            'Set olRecip = olReply.Recipients.Add("Email Address Here") ' Recipient Address
                            'olRecip.Type = olCC
                            'olReply.Body = "Hello," & vbCrLf & "Email Not Success" & vbCrLf & FailReason1 & vbCrLf & FailReason2 & vbCrLf & FailReason3 & vbCrLf & olReply.Body
                            olReply.Body = EBody & vbCrLf & olReply.Body
                            olReply.Display
                            'olReply.SentOnBehalfOfName = onBehalfOf
                            'olReply.SendUsingAccount = getGenericMailboxAccount(onBehalfOf)
                            
                            olReply.Send
                            
                            itm.UnRead = False
                          
                            itm.Move SubFolder

                End If 'IF_Check_2
                Incr = Incr + 1
                
            '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
            Next itm ' Its passing to the next statement even though loop is not completed.
            '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
            
            Set olFolder = Nothing
        End If ''IF_Check_1
    Next eFolder
End Sub

Does this answer your question? [For Each loop: Some items get skipped when looping through Outlook mailbox to delete items](https://stackoverflow.com/questions/10725068/for-each-loop-some-items-get-skipped-when-looping-through-outlook-mailbox-to-de) — niton, Mar 16 '22 at 17:51

score 1 · Answer 1 · answered Mar 17 '22 at 02:57

Your are modifying (by setting the Unread property to false) the very collection you are iterating over.

Do not use foreach - use a down loop.

set restrItems = olFolder.Items.Restrict(sFilter)
For i =  restrItems.Count to 1 Step -1
  set itm = restrItems(i)

score -1 · Answer 2 · answered Mar 16 '22 at 22:12

First of all, you need to make sure the date object is formatted in the way Outlook understands:

sFilter = "[ReceivedTime] >= '" & Todays_Date & "' AND [UNREAD]=TRUE"

Use the Format function available in VBA.

sFilter = "[ReceivedTime] > '" & Format(Todays_Date, "ddddd h:nn AMPM") & "'"

Looping through unread emails, changing unread to read, using For Each

2 Answers2