Outlook mit VBA - Mailanhang in Ordner abspeichern, wobei der Betreff der Dateiname sein soll

Hallo Forumexperten,
ich bin im Internet auf dieses Forum gestossen und habe zuerst nur BIBER direkt angemailt.
Auf Bibers Rat hin veröffentliche ich hier nun mein Anliegen, damit alle Forummitglieder etwas von der Lösung des Problems haben. Das ist mein erster Beitrag.

Ich bekomme täglich sehr viele emails von unserer Hauptgeschäftsstelle mit Rechnungsanhängen als PDF.

1. Ich möchte gerne die PDF Anhänge in einem dafür vorgesehenen Ordner ablegen, was bereits funktioniert.(siehe VBA-Makro unten)
Dazu hatte mir folgender Beitrag schon sehr weitergeholfen: Outlook 2003: Datei aus Mailanhang automatisch in Ordner verschieben oder kopieren

PROBLEM:
Leider ist der Name der jeweiligen PDF Datei NICHT die Rechnungnummer, sondern eine fortlaufende Nummer, die vom System unserer Geschaftsstelle automatisch vergeben wird.

Ich muss die PDF Datei aber als Rechnungsnummer abspeichern. Diese Rechnungsnummer finde ich im Betreff der jeweiligen Mail.
Z.B.: VAUDE-Factura 61854816

FRAGE:
Wie kann ich nun die PDF Datei mit dem Betreff der Mail als Dateinamen abspeichern.
Oder noch komplizierter: Wie kann ich NUR die Rechnungsnummer (ohne "Vaude-Factura") also nur 61854816.pdf als Dateinamen abspeichern?

Hier einmal mein bereits vorhandener VBA CODE:

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

strNewFolder = "W:\VBA_TEST\"
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


Ich hoffe, Ihr könnt mir bei der Lösung behilflich sein.

Viele Grüsse aus Spanien
Manfred

Dim strNewFolder As String
Dim objPosteingang As MAPIFolder
Dim objNewMail As MailItem
Dim oAttachment As Attachment
Dim ts() as String

strNewFolder = "W:\VBA_TEST\"  
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

'Hier die Betreffzeile der Mail lesen und dann nach Factura trennen  
ts=split(objnewmail.subject ,"Factura")  
'dann sollte in ts(1) die Rechnungsnummer mit einem Leerzeichen stehen  

Debug.Print objNewMail & ": "; intanlagen If intanlagen > 0 Then For i = 1 To intanlagen Set oAttachment = .Attachments.Item(i) oAttachment.SaveAsFile strNewFolder & "\" & trim(ts(1)) & ".pdf"  

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