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

Open in new window

Murray BrownMicrosoft Cloud Azure/Excel Solution DeveloperAsked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Wayne Taylor (webtubbs)Commented:
By "new" do you mean unread emails? if so, check the UnRead property of each item and only process those that equal True...

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
              If Item.UnRead = True Then
                '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
              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

Open in new window

0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
Murray BrownMicrosoft Cloud Azure/Excel Solution DeveloperAuthor Commented:
Thanks very much
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Outlook

From novice to tech pro — start learning today.