Outlook 2010 Dateianhänge von bestimmten Exchange Mails in Ordner verschieben

Sub application_NewMail()
Dim strNewFolder As String
Dim objPosteingang As MAPIFolder
Dim objNewMail As MailItem
Dim oAttachment As Attachment
Dim WshShell As Object
Dim strDesktop As String

Set WshShell = CreateObject("WScript.Shell")  
strDesktop = WshShell.SpecialFolders("Desktop")  

strNewFolder = strDesktop & "\" & Format(Date, "yyyymmdd")& "-" & Format(Time, "hhmm") & "_Scandaten"  
On Error GoTo check_error
MkDir(strNewFolder)

objPosteingang = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)  
For Each Item In objPosteingang.Items
    If Item.Class = olMail Then
        objNewMail = Item
        With objNewMail
            'If .SenderEmailAddress = "Report1@intern.de"  Or  .SenderEmailAddress = "Report2@extern.de"  Or .SenderEmailAddress = "Report3@intern.de" Then 'um nur Mails eines bestimmten Absenders zu bearbeiten, Kommentar entfernen (und Absenderadresse anpassen ;-))  
                If .UnRead = True Then
                    intanlagen = .Attachments.Count
                    Debug.Print objNewMail & ": "; intanlagen   
                    For i = 1 To intanlagen 'If davor eingespart: wenn intanlagen < 1 ist, wird die Schleife ohnehin nicht ausgeführt ...  
                        oAttachment = .Attachments.Item(i)
                        oAttachment.SaveAsFile(strNewFolder & "\" & oAttachment.FileName)  
                    Next
                End If
            'End If 'um nur Mails eines bestimmten Absenders zu bearbeiten, Kommentar entfernen  
        End With
    End If
Next Item
MsgBox("Alle Anhänge gespeichert.", vbOKOnly, "Verarbeitung fertig")  
Exit Sub

check_error:
Debug.Print Err.Number; Err.Description 
Err.Clear()
Resume Next

End Sub