受信したメッセージを再送信するマクロ

コメントにて以下のようなご要望をいただきました。


outlook2010で受信したメッセージを自動的に再送信するVBAプログラムを作成したいと考えているのですが、初心者のため苦戦しています。
開いているメッセージを再送信するプログラムと受信時にアクションを起こすプログラムの例は見つかったのですが、これらをつなげて受信時に自動で再送信するプログラムにしたいと考えています。
条件としては再送信時にfromおよびToを自分自身にし、CC,BCCは削除する必要があります。


受信したメッセージを OFT として保存し、それを CreateItemFromTemplate で開いて送信すると、受信したメッセージを再送するような動作になります。
マクロは以下のとおりです。

' ここをトリプルクリックでマクロ全体を選択できます。
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
    Dim objItem
    Set objItem = Session.GetItemFromID(EntryIDCollection)
    If objItem.MessageClass = "IPM.Note" Then
        ForwardAsItIs objItem
    End If
End Sub
'
Private Sub ForwardAsItIs(ByVal objMail As MailItem)
    Const TO_ADDRESS = "user@example.com" ' 再送先アドレスを指定
    Dim strFileName As String
    Dim fwMail As MailItem
    Dim i As Integer
    ' 自分自身からのメールはループを防ぐため再送しない
    If objMail.SenderEmailAddress = Session.CurrentUser.Address Then
        Exit Sub
    End If
    ' 受信したメッセージを OFT として保存
    strFileName = Environ("TEMP") & "~forward.oft"
    objMail.SaveAs strFileName, olTemplate
    ' 保存した OFT からメッセージを作成
    Set fwMail = Application.CreateItemFromTemplate(strFileName)
    ' 宛先をすべて削除
    With fwMail.Recipients
        For i = .Count To 1 Step -1
            .Remove i
        Next
    End With
    ' 宛先を追加して送信
    fwMail.Recipients.Add TO_ADDRESS
    fwMail.Send
End Sub

マクロの登録方法やメニューへの追加について