Einzelne Emails per Makro weiterleiten

Sub ForwardMail(objMail As MailItem)
    Dim objForward As MailItem
    Set objForward = objMail.Forward
    With objForward
        .To = "xyz@domain.de"  
        .Subject = "Test"  
        .Send
    End With
End Sub

Set Folder = Folders.FolderPath (\\x@y.com\Posteingang\Sonstiges)

set folder = Application.Session.Stores("x@y.com").GetRootFolder.Folders("Posteingang").Folders("Sonstiges")

Sub Test(oMail As Outlook.MailItem)

 Dim objMail_In           As MailItem
 Dim objMail_Out        As MailItem
 Dim Folder                  As Outlook.MAPIFolder
 Dim SubFolder           As Outlook.Folder
 Dim TestFolder          As Outlook.Folder
 Dim myOlApp             As Outlook.Application
 Dim FolderName       As String
 Dim Ns                        As Outlook.NameSpace
 Dim myEntryID          As String
 Dim myStoreID          As String
 
 
 FolderName = "Sonstiges"  

'NDL-Nummer aus Betreffzeile filtern  
 Dim arr As Variant
 Dim i As Long
  
'Liste der zu entfernenden Begriffe  
 arr = Array("XX", YY")  
  
 For i = 0 To UBound(arr)
    oMail.Subject = Replace(oMail.Subject, arr(i), "", , , vbTextCompare)  
    Next
    If oMail.Saved = False Then
       oMail.Save
    End If

 Select Case TypeName(Application.ActiveExplorer)
 Case "Explorer"  
 Set myItem = oMail
 Case Else
 End Select

 Set objMail_In = myItem
 Set objMail_Out = myItem.Forward
 Set myOlApp = Outlook.Application
 Set Ns = Application.GetNamespace("MAPI")  
 Set Folder = myOlApp.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders(FolderName)  
        myEntryID = Folder.EntryID
        myStoreID = Folder.StoreID
 Set Folder = Application.Session.Stores("x@y.com").GetRootFolder.Folders("Posteingang").Folders("Sonstiges")  
 
 
 With objMail_Out
 .To = "x" & objMail_In.Subject & "@y.com" 'Empfänger  
 .Subject = "XX" & oMail.Subject & "YY"  
 .Body = "Anbei der Orginalanhang."  
 .Send
 End With
 
 With objMail_In
   .Subject = "XX" & oMail.Subject & "YY"  
   .Move Folder
 End With
 
 End Sub