Option Explicit

Private Const START_FOLDER As String = "e:\test\post\"   ' Der Startordner

Private Sub Application_NewMail()
   Dim strFolder As String       ' der Ordner in welche die Anhänge gelegt werden
   Dim objFolder As MAPIFolder   ' der Posteingang
   Dim objItem As Object         ' ein Objekt im Posteingang
   Dim objMailItem As MailItem   ' eine Mail im Posteingang
   Dim objRe As Object           ' ein 'Regular Expression Object'
   Dim objMc As Object           ' eine MatchCollection, das Ergebnis von objRe.Execute
   Dim i As Integer              ' Zähler über Anhänge
   
   Set objRe = CreateObject("vbscript.regexp")
   objRe.Pattern = "(\d{3,})"  ' eine Zahl die aus mindestens 3 Ziffern besteht, danach wird im Betreff gesucht
   
   ' Der Standard-Posteingangsordner
   Set objFolder = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
   ' Dort alle Elemente durchlaufen
   For Each objItem In objFolder.Items
      ' Nur Mails beachten
      If TypeOf objItem Is MailItem Then
         Set objMailItem = objItem
         With objMailItem
            ' nur ungelesene Mails mit >= 1 Anhang und einer min. 3-stelligen Ziffer im Betreff beachten
            If .UnRead = True And .Attachments.Count > 0 And objRe.Test(.Subject) Then
               Set objMc = objRe.Execute(.Subject)
               ' die Ziffernfolge aus dem Betreff extrahieren und als Unterverzeichnis hernehmen
               strFolder = START_FOLDER & objMc(0).SubMatches(0) & "\"
               ' Debug.Print strFolder
               ' ggf. dieses Unetrverzeichnis erstellen
               If Len(Dir(strFolder, vbDirectory)) = 0 Then MkDir strFolder
               ' Dort die Anhänge abspeichern
               For i = 1 To .Attachments.Count
                  .Attachments(i).SaveAsFile strFolder & "\" & .Attachments(i).FileName
               Next i
               Set objMc = Nothing
               ' am Ende noch die Mail als Gelesen markieren
               .UnRead = False
            End If
         End With
      End If
   Next objItem
   Set objRe = Nothing
End Sub