自動転送時のヘッダーをシンプルにするマクロ


返信時や転送時のヘッダーをシンプルにするマクロについて以下のようなご要望をいただきました。


お世話になります。
上記のマクロ、大変便利でありがたいのですが、
メッセージルールを活用して、自動転送するさい、自動的に実行するようにはできないものでしょうか。



自動仕分けのルールの「スクリプトを実行する」というアクションで、一定のパラメータを持つ任意のマクロを使用出来ます。

そのマクロでヘッダーをシンプルにして転送するマクロを実行することで、ご要望の動作が可能です。

以下のマクロで FORWARD_ADDRESS に転送先のアドレスを指定し、「スクリプトを実行する」のスクリプトとして ForwardSimpleByRule を指定してください。
なお、すでに前述の返信時や転送時のヘッダーをシンプルにするマクロが定義されている場合、いったんそれを削除して以下のものに置き換えてください。

' ここをトリプルクリックでマクロ全体を選択できます。
' ルールによる転送
Public Sub ForwardSimpleByRule(objMail As MailItem)
    Const FORWARD_ADDRESS = "forward@example.com" ' 転送先のアドレスを指定します
    Dim objForward As MailItem
    With objMail
        Set objForward = .Forward
        ReplaceHeader objForward, .SenderName, .SentOn, "Forward"
        objForward.To = FORWARD_ADDRESS 
        objForward.Send
    End With
End Sub
' 全員に返信
Public Sub ReplyAllSimple()
    Dim objMail As MailItem
    With ActiveInspector.CurrentItem
        Set objMail = .ReplyAll
        ReplaceHeader objMail, .SenderName, .SentOn, "Reply"
        objMail.Display
    End With
End Sub
' 転送
Public Sub ForwardSimple()
    Dim objMail As MailItem
    With ActiveInspector.CurrentItem
        Set objMail = .Forward
        ReplaceHeader objMail, .SenderName, .SentOn, "Forward"
        objMail.Display
    End With
End Sub
' ヘッダ置き換え
Private Sub ReplaceHeader(objMail As MailItem, strSender As String, dtSentOn As Date, strMode As String)
    On Error Resume Next
    Dim objReply As MailItem
    Dim strBody As String
    Dim s As Integer
    Dim e As Integer
    '
    If objMail.BodyFormat = olFormatHTML Then
        strBody = objMail.HTMLBody
        s = InStr(strBody, "<a name=""_MailOriginal"">")
        e = InStr(s, strBody, "</p>")
        strBody = Left(strBody, s - 1) & "<b>(" & dtSentOn & "), " & strSender & " </b> wrote:" & Mid(strBody, e)
        'strBody = Left(strBody, s - 1) & "<b>From: </b>" & strSender & Mid(strBody, e)
        objMail.HTMLBody = strBody
    Else
        Dim strPrefix As String
        strPrefix = ""
        strBody = objMail.Body
        s = InStr(strBody, "-----Original Message-----")
        If Mid(strBody, s - 1, 1) <> vbLf Then
            strPrefix = GetPrefixText(strMode)
        End If
        e = InStr(s, strBody, vbCrLf & strPrefix & vbCrLf)
        strBody = Left(strBody, s - 1) & "(" & dtSentOn & "), " & strSender & " wrote:" & Mid(strBody, e)
        'strBody = Left(strBody, s - 1) & "-----Original Message-----" & vbCrLf & "From: " & strSender & Mid(strBody, e)
        objMail.Body = strBody
    End If
End Sub
'
Function GetPrefixText(strMode As String) As String
    On Error Resume Next
    Dim wshShell As Variant
    Dim iStyle As Integer
    Dim strPrefix As String
    strPrefix = ""
    Set wshShell = CreateObject("WScript.Shell")
    iStyle = wshShell.RegRead("HKCU\Software\Microsoft\Office\" & Left(Application.Version, 2) & _
        ".0\Outlook\Preferences\" & strMode & "Style")
    If iStyle = 1000 Then
        strPrefix = wshShell.RegRead("HKCU\Software\Microsoft\Office\" & Left(Application.Version, 2) & _
            ".0\Outlook\Preferences\PrefixText")
        If strPrefix = "" Then
            strPrefix = "> "
        End If
    End If
    GetPrefixText = strPrefix
End Function

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

コメントを残す

以下に詳細を記入するか、アイコンをクリックしてログインしてください。

WordPress.com ロゴ

WordPress.com アカウントを使ってコメントしています。 ログアウト / 変更 )

Twitter 画像

Twitter アカウントを使ってコメントしています。 ログアウト / 変更 )

Facebook の写真

Facebook アカウントを使ってコメントしています。 ログアウト / 変更 )

Google+ フォト

Google+ アカウントを使ってコメントしています。 ログアウト / 変更 )

%s と連携中