Автоматическая пересылка писем

Option Explicit
 
Public Sub Today()
 
Dim myFolder As Folder
 
    Set myFolder = GetInboxSubFolder("* 0. Today")
    If Not myFolder Is Nothing Then
        MoveItemAndMarkAsUnread myFolder
    End If
 
End Sub
 
Private Function GetInboxSubFolder(folderName As String) As Folder
 
Dim myNamespace As NameSpace
Dim myInbox As Folder
 
    Set myNamespace = Application.GetNamespace("MAPI")
    Set myInbox = myNamespace.GetDefaultFolder(olFolderInbox)
    Set GetInboxSubFolder = myInbox.Folders(folderName)
 
End Function
 
Private Sub MoveItemAndMarkAsUnread(myFolder As Folder)
 
Dim myExplorer As Explorer
Dim mySelection As Selection
 
    Set myExplorer = Application.ActiveExplorer
    Set mySelection = myExplorer.Selection
 
Dim i As Integer
Dim myItem As MailItem
 
    For i = mySelection.Count To 1 Step -1
 
        mySelection.Item(i).UnRead = True
        mySelection.Item(i).Move myFolder
 
    Next i
 
End Sub

Private Sub Application_NewMail()
'- что делать с новым письмом
End Sub