Excel VBA Outlook loop through new email items only

Murray Brown
Murray Brown used Ask the Experts™
on
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

Comment
Watch Question

Do more with

Expert Office
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®
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

Murray BrownASP.net/VSTO Developer

Author

Commented:
Thanks very much

Do more with

Expert Office
Submit tech questions to Ask the Experts™ at any time to receive solutions, advice, and new ideas from leading industry professionals.

Start 7-Day Free Trial