I am looping through outlook unread emails using For each and next but its not working-CodePudding

I wrote code for outlook emails the macro has to pick up the unread email and with other criteria.

The code is working fine but "For Each itm In olFolder.Items.Restrict(sFilter)" is not working. For ex there are 4 unread emails in the inbox and with For each loop it should loop 4 times but the loop is happening only 2 times without any reason..

Please do help with this issue.

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

CodePudding user response：

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)

CodePudding user response：

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") & "'"