Outlook自動転送マクロ

Last Update ; 24/Feb/2013

Outlookを企業内で使っている方からの依頼で、クライアント側で受信メールをGalaxy（Gmail）に自動転送するマクロを作成しました。

説明用に作成したPPTファイルの画像を添付しながら、概要を記したいと思います。（作成したマクロはこのページの一番下に添付しておきます。）

OfficeはMicrosoft Office Professional Plus 2010。Outlookのバージョンは14.0.6023.1000(32ビット)です。

注）添付のマクロを使用される場合は自己責任にてお願いします。特に、企業内のメールシステムで使用される場合は、個人情報保護ポリシーやセキュリティー設定に十分注意してください。

【仕様と制限事項】

【事前準備】

デジタル証明書の作成

「開発」オプションの表示

 【マクロの登録】

  

【マクロのセキュリティの確認】

【マクロの中断方法】

【転送済メールの削除】

【転送メールを保存しない設定】

【Windowsの画面プロパティ設定】

【自動更新後に再起動しない設定】

【転送メールでのReply-Toの指定】

【メールでのリモート操作によるマクロの中断】

【マクロ例】

' Outlook受信メール自動転送マクロ Ver 1.15
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
    Dim objItem
    Set objItem = Session.GetItemFromID(EntryIDCollection)
    If objItem.MessageClass = "IPM.Note" Then
        AutoForward objItem
    End If
End Sub
Private Sub AutoForward(ByVal objMail As MailItem)
    '
    '以下のメールアドレスを転送先のメールアドレスに書きなおしてください
    Const ForwardToAddress = "xxxxxxxx@gmail.com"  ' 転送先アドレスを指定
    '
    Dim strFileName As String
    Dim fwMail As MailItem
    Dim i As Integer
    Dim strSenderName As String
    Dim strSenderEmailAddress As String
    Dim strSubject As String
    Dim strTo As String
    Dim strCc As String
'
' 受信メールの自動仕分けルールや迷惑メールフィルタと併用した場合のエラー対策
On Error GoTo ErrorTrap
    '
    ' 受信メールから表題や送受信者情報を取得
    strSubject = objMail.Subject    ' 表題を取得
    strSenderName = objMail.SenderName  ' 送信者名を取得
    strSenderEmailAddress = objMail.SenderEmailAddress  ' Emailアドレスを取得
    strTo = objMail.To  ' 宛先を取得
    strCc = objMail.CC  ' CC宛先を取得
    '
    ' 送信者名と送信者のEmailアドレスの表示処理
    ' 送信者名と送信者のEmailアドレスが同じ場合はEmailアドレスのみ表示
    If strSenderName = strSenderEmailAddress Then
        strSenderName = strSenderEmailAddress
    ' 送信者名と送信者のEmailアドレスが異なる場合は「送信者名＋」で表示
    Else
        ' 送信者のメールアドレスがEmailの場合
        If InStr(strSenderEmailAddress, "@") Then
            strSenderName = strSenderName + "<" + strSenderEmailAddress + ">"
        ' 送信者のメールアドレスがExchangeの場合はSMTPアドレスを取得して表示
        Else
            strSenderEmailAddress = _
            objMail.Sender.PropertyAccessor.GetProperty("http://schemas." _
            & "microsoft.com/mapi/proptag/0x39FE001E")
            strSenderName = strSenderName + "<" + strSenderEmailAddress + ">"
        End If
    End If
    '
    '　宛先がBccの場合の宛先表示処理
        ' Bccで送信されてきた時はBccと表示
        If strTo = "" Then
            strTo = "Bcc"
        Else
        End If
    '
    ' 受信メールをOFTとして保存しOFTから新規メッセージを作成
    strFileName = Environ("TEMP") & "~forward.oft"  '受信メールをOFTとして保存
    objMail.SaveAs strFileName, olTemplate
    Set fwMail = Application.CreateItemFromTemplate(strFileName)    ' メッセージを作成
    With fwMail.Recipients  ' 元メールからコピーされた宛先を削除
        For i = .Count To 1 Step -1
            .Remove i
        Next
    End With
    '
    ' 転送先アドレスを設定
    fwMail.To = ForwardToAddress
    '
    ' 転送先から特定の表題のメールを受信した時にマクロを中断し転送先に中断を通知
    If strSubject = "自動転送中断" Then
        If strSenderEmailAddress = ForwardToAddress Then
            ' 通知メールを作成し送信
            fwMail.Subject = "リモート操作により自動転送を中断しました"
            fwMail.Body = "PCの画面にポップアップしているメッセージボックス内の[OK]を" _
                          & "クリックすると自動転送を再開します。"
            fwMail.Send
            ' PCの画面上にメッセージボックスを表示
            MsgBox "メールによるリモート操作で自動転送用のマクロを中断しています。" & _
                        vbCrLf & "[OK]をクリックすると再開します。"
            Exit Sub
        Else
        End If
    Else
    End If
    '
    ' 転送メールにReply-Toを付加する場合
    ' （サーバー側が送信メールへのReply-Toの付加を許可している場合のみ有効にする）
    ' fwMail.SentOnBehalfOf = strSenderEmailAddress
    '
    ' 表題に送信者名を追記
    fwMail.Subject = strSubject & "<" & strSenderName & ">"
    '
    fwMail.Body = vbCrLf & vbCrLf + fwMail.Body
    '
    ' CCがある場合は本文にCCを追記
    If strCc <> "" Then
        fwMail.Body = " " & vbCrLf & "[Cc] " + strCc + fwMail.Body
    Else
    End If
    '
    ' 本文に時刻、件名、送信者名、Toを追記
    fwMail.Body = "[Sent] " + FormatDateTime(Now, vbShortDate) & " " & _
                        FormatDateTime(Now, vbShortTime) & vbCrLf & _
                       "[Subject] " + strSubject & vbCrLf & _
                       "[From] " + strSenderName & vbCrLf & _
                       "[To] " + strTo + fwMail.Body
'
'　転送メールを送信
    fwMail.Send '
'
ErrorTrap:
'
End Sub

【参照サイト】

Outlook 研究所
http://outlooklab.wordpress.com/2012/07/28/

Slashdot
http://slashdot.jp/journal/454776

【更新履歴】

24/Feb/2012
マクロVer 1.15。本文の冒頭に日時も追記する様に変更。マクロ内のコメントを整理。

18/Feb/2012
マクロVer 1.14。 メールでマクロを中断した際のお知らせメールに本文を追加。（マクロの機能自体に変更はありません。）

15/Feb/2013
マクロVer 1.13。メールでのリモート操作によるマクロの中断の際に転送先に通知メールを送る様に変更。

14/Feb/2013
マクロVer 1.12。メールでのリモート操作によるマクロの中断は転送先メールアドレスからに限定。

13/Feb/2013
マクロVer 1.11。メールでのリモート操作によるマクロの中断機能を追加。

12/Feb/2013
制限事項を追記。
マクロVer 1.10。Bccで送信されてきたメールを転送する際には本文の冒頭に"[To] Bcc"とと表示する様に変更。

11/Feb/2013
転送メールを保存しない設定方法を追記。
マクロVer 1.09。Reply-Toについてのオプションを追加し、説明資料も追加。

10/Feb/2013
マクロVer 1.08。マクロ中のコメントを整理しました。処理は変えていません。
マクロVer 1.07。送信者がExchangeユーザの場合もSMTPアドレスを検索して本文の冒頭に表示する様に変更。
マクロVer 1.06。エラー処理（迷惑メールフィルタ起動時対応）を追加。

09/Feb/2013
マクロVer 1.04。転送メールの本文の冒頭に表示する「送信者名」について、Exchangeユーザからのメールの場合は「送信者名」のみ表示（従来通り）し、Emailアドレスからのメールの場合は「送信者名＋Emailアドレス」を表示する仕様に変更。但し、「送信者名」と「Emailアドレス」が同じ場合は「送信者名」のみ表示。

07/Feb/2013
マクロVer 1.03。初掲載。

[続きを読む]