Outlook code save attachment

[harolda1980]

Hierbij een code die mail in een map oppakt en die saved in een bepaalde map.
De attachments worden opgeslagen in een bepaalde map.

maar als er 3 berichten staan pakt hij er maar twee op. Weet iemand waar dit probleem zit?

Sub SaveAttachmentsToFolder()

    On Error GoTo SaveAttachmentsToFolder_err
' Declare variables
    Dim ns As NameSpace
    Dim Inbox As MAPIFolder
    Dim SubFolder As MAPIFolder
    Dim DestFolder As MAPIFolder
    Dim Item As Object
    Dim Atmt As Attachment
    Dim FileName As String
    Dim i As Integer
    Dim varResponse As VbMsgBoxResult
   
    Set ns = GetNamespace("MAPI")
    Set Inbox = ns.GetDefaultFolder(olFolderInbox)
    Set SubFolder = Inbox.Folders("Automeldingen") ' Enter correct subfolder name.
    Set DestFolder = Inbox.Folders("Saved mail")
    i = 0
' Check subfolder for messages and exit of none found
    If SubFolder.Items.Count = 0 Then
        MsgBox "There are no messages in the Sales Reports folder.", vbInformation, _
               "Nothing Found"
        Exit Sub
    End If
' Check each message for attachments
    For Each Item In SubFolder.Items
        For Each Atmt In Item.Attachments
' Check filename of each attachment and save if it has "xls" extension
               ' This path must exist! Change folder name as necessary.
                FileName = "C:\Email Attachments\" & Atmt.FileName
                Atmt.SaveAsFile FileName
                i = i + 1
            
        Next Atmt
      
        Item.Move DestFolder
    Next Item
' Show summary message
    If i > 0 Then
        varResponse = MsgBox("I found " & i & " attached files." _
        & vbCrLf & "I have saved them into the C:\Email Attachments folder." _
        & vbCrLf & vbCrLf & "Would you like to view the files now?" _
        , vbQuestion + vbYesNo, "Finished!")
' Open Windows Explorer to display saved files if user chooses
        If varResponse = vbYes Then
            Shell "Explorer.exe /e,C:\Email Attachments", vbNormalFocus
        End If
    Else
        MsgBox "I didn't find any attached files in your mail.", vbInformation, "Finished!"
    End If
' Clear memory
SaveAttachmentsToFolder_exit:
    Set Atmt = Nothing
    Set Item = Nothing
    Set ns = Nothing
    Exit Sub
' Handle Errors
SaveAttachmentsToFolder_err:
    MsgBox "An unexpected error has occurred." _
        & vbCrLf & "Please note and report the following information." _
        & vbCrLf & "Macro Name: GetAttachments" _
        & vbCrLf & "Error Number: " & Err.Number _
        & vbCrLf & "Error Description: " & Err.Description _
        , vbCritical, "Error!"
    Resume SaveAttachmentsToFolder_exit
End Sub