Option Explicit

Sub SaveAttachements()

  Dim objNameSpace As Outlook.NameSpace
  Dim sAttachementDir As String
  Dim objSourceFolder As Outlook.Folder
  Dim objTargetFolder As Outlook.Folder
  Dim objMailItem As Outlook.MailItem
  Dim objCopiedItem As Outlook.MailItem
  Dim i, j As Integer
  Dim sRootFolder As String
  Dim sSubjectPattern As String
      
  sSubjectPattern = "*"
  sAttachementDir = "c:\temp\outlook\"
  
  Set objNameSpace = Application.GetNamespace("MAPI")
  
  Set objSourceFolder = objNameSpace.GetDefaultFolder(olFolderInbox)
  sRootFolder = objNameSpace.DefaultStore.GetRootFolder.Name
  Set objTargetFolder = GetMAPIFolder("\" & sRootFolder & "\temp")
  
  ' Alle Mails im Ordner durchlaufen
  For i = objSourceFolder.Items.Count To 1 Step -1
    Set objMailItem = objSourceFolder.Items.Item(i)
    
    If objMailItem.Subject Like sSubjectPattern Then
    
    ' Attachements im Dateisystem speichern
    With objMailItem.Attachments
      If .Count > 0 Then
       For j = 1 To .Count
          .Item(j).SaveAsFile sAttachementDir & .Item(j).FileName
        Next j
      End If
    End With
    
    ' Hier Code zur Namensgebung einfügen
    
    ' Mail kopieren
    'Set objCopiedItem = objMailItem.Copy
    'objCopiedItem.Move objTargetFolder

    
    ' Mail verschieben
    objMailItem.Move objTargetFolder
  
  End If
  
  Next
  
End Sub

Private Function GetMAPIFolder(sPath As String) As Folder
  
  Dim objNameSpace As NameSpace
  Dim objFolder As Folder
  Dim i As Integer
  Dim sDir As String
     
  Set objFolder = Nothing
  If Left(sPath, Len("\")) = "\" Then
      sPath = Mid(sPath, Len("\") + 1)
  Else
      Set objFolder = Application.ActiveExplorer.CurrentFolder
  End If
  
  While sPath <> ""
      i = InStr(sPath, "\")
      If i Then
          sDir = Left(sPath, i - 1)
          sPath = Mid(sPath, i + Len("\"))
      Else
          sDir = sPath
          sPath = ""
      End If
      If IsNothing(objFolder) Then
          Set objNameSpace = Application.GetNamespace("MAPI")
          Set objFolder = objNameSpace.Folders(sDir)
      Else
          Set objFolder = objFolder.Folders(sDir)
      End If
  Wend
  Set GetMAPIFolder = objFolder
    
End Function
 
Private Function IsNothing(objObject As Object) As Boolean
    If TypeName(objObject) = "Nothing" Then
        IsNothing = True
    Else
        IsNothing = False
    End If
End Function