コメントにて以下のようなご要望をいただきました。
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