Outlook 2003: Datei aus Mailanhang automatisch in Ordner verschieben oder kopieren

Sub Application_NewMail()
Dim strNewFolder As String
Dim objPosteingang As MAPIFolder
Dim objNewMail As MailItem
Dim aAttachment As Attachment

strNewFolder = "E:\mailanhang\" & Format(Date, "ddmmyy")  
On Error Resume Next
MkDir strNewFolder
Set objPosteingang = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)  
For Each objNewMail In objPosteingang.Items
   With objNewMail
   If .UnRead = True Then
       intAnlagen = .Attachments.Count
       If intAnlagen > 0 Then
           For i = 1 To intAnlagen
              Set oAttachment = .Attachments.Item(i)
              oAttachment.SaveAsFile strNewFolder & "\" & oAttachment.FileName  
           Next i
       End If
   End If
   End With
Next objNewMail
End Sub

Sub Application_NewMail()
Dim strNewFolder As String
Dim objPosteingang As MAPIFolder
Dim objNewMail As MailItem
Dim oAttachment As Attachment

strNewFolder = "D:\mailanhang\" & Format(Date, "ddmmyy")  
On Error GoTo check_error
MkDir strNewFolder
Back1:
Set objPosteingang = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)  
For Each Item In objPosteingang.Items
  If Item.Class = olMail Then
   Set objNewMail = Item
   With objNewMail
   If .UnRead = True Then
  
  intanlagen = .Attachments.Count
  Debug.Print objNewMail & ": "; intanlagen  
  If intanlagen > 0 Then
     For i = 1 To intanlagen
        Set oAttachment = .Attachments.Item(i)
           oAttachment.SaveAsFile strNewFolder & "\" & oAttachment.FileName  
     Next i
   End If
End If
End With
End If
Next Item

check_error:
Debug.Print Err.Number; Err.Description
If Err.Number = 75 Then ' Fehler beim Zugriff auf Pfad -- ignorieren wir mal  
   Err.Clear
   GoTo Back1:
Else
   Err.Raise Err.Number, Err.Description
End If

Err.Clear
Resume Next

End Sub

...
Set fso = CreateObject("Scripting.FileSystemObject")  
For i = 1 To intanlagen
	Set oAttachment = .Attachments.Item(i)
	strFileName = oAttachment.FileName
	strFileType = ""  
	If InstrRev(strFileName, ".") Then strFileType = LCase(Mid(strFileName, InstrRev(strFileName, ".")))  
	Select Case strFileType
	Case ".xls" 'Typ mit Kleinbuchstaben angeben  
		strSubFolder = "Excel"  
	Case ".csv"  
		strSubFolder = "CSV"  
	Case Else
		strSubFolder = "Andere"  
	End Select
	strSavePath = strNewFolder & "\" & strSubFolder  
	If Not fso.FolderExists(strSavePath) Then fso.CreateFolder(strSavePath)
	oAttachment.SaveAsFile strSavePath & "\" & oAttachment.FileName  
Next i
...

MsgBox "Alle Anhänge gespeichert.", vbOKOnly , "Verarbeitung fertig"

check_error:

Sub Application_NewMail()
Dim strNewFolder As String
Dim objPosteingang As MAPIFolder
Dim objNewMail As MailItem
Dim oAttachment As Attachment

strNewFolder = "C:\TEMP\" & Format(Date, "yyyymmdd") & "-" & Format(Time, "hhmm") & "_Scandaten" 'Hier könnte die Benennung auch getauscht werden, bzw. ein anderer Pfad angegeben werden.  
On Error GoTo check_error
MkDir strNewFolder
Back1:
Set objPosteingang = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)  
For Each Item In objPosteingang.Items
  If Item.Class = olMail Then
   Set objNewMail = Item
   With objNewMail
   If .SenderEmailAddress = "test@absender.de" Then 'Hier die Absenderadresse, sonst Zeile löschen  
   If .UnRead = True Then 'Diese Zeile bewirkt, dass nur ungelesene Items exportiert werden.  
  
  intanlagen = .Attachments.Count
  Debug.Print objNewMail & ": "; intanlagen  
  If intanlagen > 0 Then
     For i = 1 To intanlagen
        Set oAttachment = .Attachments.Item(i)
           oAttachment.SaveAsFile strNewFolder & "\" & oAttachment.FileName  
     Next i
   End If
   End If 'Dieses EndIf raus, wenn keine Beschränkung auf den Absender  
End If
End With
End If
Next Item
MsgBox "Alle Anhänge gespeichert.", vbOKOnly, "Verarbeitung fertig" 'Hinweisbox der Fertigstellung. Wenn unerwünscht, Zeile raus  
Exit Sub

check_error:
Debug.Print Err.Number; Err.Description
If Err.Number = 75 Then ' Fehler beim Zugriff auf Pfad -- ignorieren wir mal  
   Err.Clear
   GoTo Back1:
Else
   Err.Raise Err.Number, Err.Description
End If

Err.Clear
Resume Next

End Sub

Module Module1

    Sub Main()
    End Sub
    Sub application_NewMail()
        Dim strNewFolder As String
        Dim objPosteingang As MAPIFolder
        Dim objNewMail As MailItem
        Dim oAttachment As Attachment
        strNewFolder = "C:\TEMP\" & Format(Date, "yyyymmdd")& "-" & Format(Time, "hhmm") & "_Scandaten"  
        On Error GoTo check_error
        MkDir(strNewFolder)
Back1:
        objPosteingang = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)  
        For Each Item In objPosteingang.Items
            If Item.Class = olMail Then
                objNewMail = Item
                With objNewMail
                    If .SenderEmailAddress = "test@absender.de" Then  
                        If .UnRead = True Then
                            intanlagen = .Attachments.Count
                            Debug.Print objNewMail & ": "; intanlagen   
                            If intanlagen > 0 Then
                                For i = 1 To intanlagen
                                    oAttachment = .Attachments.Item(i)
                                    oAttachment.SaveAsFile(strNewFolder & "\" & oAttachment.FileName)  
                                Next i
                            End If
                            End With 
            End If
        Next Item
        MsgBox("Alle Anhänge gespeichert.", vbOKOnly, "Verarbeitung fertig")  
        Exit Sub
check_error:
        Debug.Print Err.Number; Err.Description 
        End if
        Err.Clear()
        Resume Next

    End Sub

                                Next
                            End If
                        End If
                    End If
                End With
            End If
        Next






    End Sub

End Module