Emails weiterleiten mit Regel oder makro

Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
    Dim varEntryIDs, objItem, i As Integer, dic As Object
    Set dic = CreateObject("scripting.dictionary")  
    dic.Add "030","user1@domain.de"  
    dic.Add "040","user1@domain.de"  
    dic.Add "080","user2@domain.de"  
    dic.Add "089","user2@domain.de"  
    keys = dic.Keys
    
    varEntryIDs = Split(EntryIDCollection, ",")  
    For i = 0 To UBound(varEntryIDs)
        Set objItem = Application.Session.GetItemFromID(varEntryIDs(i))
        If objItem.Class = olMail Then
            For Each key In keys
            	If Left(objItem.Subject,Len(key)) = key Then
            		With objItem.Forward
	                	.To = dic.Item(key)
	                	.Send
	                	Exit For
	            	End With
            	End If            	
            Next
        End If
    Next
End Sub