Excel VBA Outlook loop through new email items only

Hi

I am using the following code to loop through all the emails in Outlook. How do I loop through new mail items only

Sub oLoop_Through_Emails_Save_Attachments()

Dim MessageInfo As String

On Error GoTo EH:

    Dim olApp As Outlook.Application
    
    OutlookOpened = False
    On Error Resume Next
    Set olApp = GetObject(, "Outlook.Application")
    If Err.Number <> 0 Then
        Set olApp = New Outlook.Application
        OutlookOpened = True
    End If
    
    On Error GoTo 0

    If olApp Is Nothing Then
        MsgBox "Cannot start Outlook.", vbExclamation
        Exit Sub
    End If

    For Each oaccount In olApp.Session.Accounts
    
        If oaccount = "copies@lesedidrilling.com" Then
        
          Set Store = oaccount.DeliveryStore
          Set Folder = Store.GetDefaultFolder(olFolderInbox) 'here it selects the inbox folder of account.
          
          For Each Item In Folder.Items
                 
              'Get Email Details
              oSender = Item.SenderName
              oSubject = Item.Subject
              oDateSent = Item.SentOn
              oDateReceived = Item.ReceivedTime
              
              AttchmtCnt = Item.Attachments.Count
              If AttchmtCnt > 0 Then
                  For Each Atmt In Item.Attachments
                      FileName = "C:\Users\User\Documents\Email Attachments\" & Atmt.FileName
                      Atmt.SaveAsFile FileName
                      i = i + 1
                      
                                      MessageInfo = "" & _
                    "Sender : " & Item.SenderEmailAddress & vbCrLf & _
                    "Sent : " & Item.SentOn & vbCrLf & _
                    "Received : " & Item.ReceivedTime & vbCrLf & _
                    "Subject : " & Item.Subject & vbCrLf & _
                    "Size : " & Item.Size & vbCrLf & _
                    "Message Body : " & vbCrLf & Item.Body
                      
                  Next Atmt
              End If
              
          Next
          
        End If
        
    Next
    
    Set olApp = Nothing
    Set Atmt = Nothing
    Set Item = Nothing
    Exit Sub
EH:
MsgBox Err.Description
    Set olApp = Nothing
    Set Atmt = Nothing
    Set Item = Nothing
    
End Sub

Select allOpen in new window