転送メールを受け取った時、転送元メールに多くのメールアドレスが含まれたものだと、その情報だけで表示ウィンドウが埋め尽くされてしまい、転送メール本文までページスクロールさせるなど面倒になってきて、メールを読む気も失せてしまうことがあります。

そうならないための工夫として、転送メールの作成側で、転送元メールの宛先や写しに設定されたメールアドレス部分を削除したり、そのフォントサイズを小さく変更して行の高さを狭めることなどが考えられます。

ここでは、このフォントサイズを小さくする作業を、Outlookに組み込んだVBAプログラムで行えるようにしようと思います。

ツールの使用イメージ

Outlookメール編集ウィンドウで、クイックアクセスツールバーのコマンド（Project1.HeaderSizeCompact）ボタンを押すと、転送元メールの宛先や写しに設定されたメールアドレス部分のフォントサイズを小さく変更します。

同じくコマンド（Project1.HeaderSizeReturn）ボタンを押すと、フォントサイズを元に戻します。実際には、メールヘッダの ”From:” 部分のフォントサイズに合わせるように変更します。

モジュール構成

このツールプログラムは次の２つのモジュールで構成されます。
・HeaderSize.bas　メインモジュール
・ClassWord.cls　   Word編集のクラスモジュール

モジュールファイルの添付

Outlookにそのままインポートできるモジュールファイルを以下に添付します。ファイルをダウンロードして解凍したら、VBEを開いてファイルインポートします。
VBEの基本的な操作は「VBA Outlook開発環境の整備」を参照ください。

プログラム組込み後のVBEイメージです。

クイックアクセスツールバーにコマンド追加

Outlookウィンドウで、クイックアクセスツールバーにコマンドボタンとして、Project1.HeaderSizeCompactとProject1.HeaderSizeReturnを追加します。ボタンアイコンはお好みで適当なものに変更してもよいでしょう。

プログラムの解説

HeaderSize.basメインモジュールのプログラムの主な内容を説明します。

HeaderSizeCompactは、転送元メールのヘッダのフォントサイズを小さく変更して、ヘッダ部をコンパクト化します。HeaderSizeReturnは、フォントサイズを元に戻します。
両方とも、FromPatternLoopを呼び出しますが、パラメータが0より大きい場合は、変更後のヘッダのフォントサイズ（ここではフォントサイズ＝2）を指定し、パラメータが0以下の場合は、ヘッダのフォントサイズを元に戻すことを指定します。

Public Sub HeaderSizeCompact()
    Call FromPatternLoop(2)
End Sub

Public Sub HeaderSizeReturn()
    Call FromPatternLoop(0)
End Sub

FromPatternLoopは、メールヘッダのFromアイテムの２つのパターン「From:」「差出人:」に対応してループをまわして、HeaderSize関数を呼び出します。
また、On Error GoToを定義してエラー発生時に備えます。これは、テキスト形式のメールの時にフォントサイズを変更できず、HeaderSize関数内でエラーが発生するためです。

Private Sub FromPatternLoop(nFontSize As Single)
    On Error GoTo ERROR_EXIT
    
    Dim oWord As ClassWord: Set oWord = New ClassWord
    
    Dim sFrom As Variant
    For Each sFrom In Split("From:,差出人:", ",")
        Call HeaderSize(nFontSize, CStr(sFrom), oWord)
    Next sFrom
    Exit Sub

ERROR_EXIT:
    MsgBox "フォントサイズを変更できません。", vbCritical
End Sub

HeaderSizeは、転送メールヘッダのフォントサイズを変更する関数です。ヘッダサイズをコンパクト化する時と、ヘッダサイズを元に戻す時で処理を共用しています。
nFontSizeはフォントサイズを指定するパラメータで、0より大きい場合は変更サイズを、0以下の場合はサイズを元に戻すことを指定します。
メール文頭に移動してから、メールヘッダのFromアイテム名を検索します。

Private Sub HeaderSize(nFontSize As Single, sFrom As String, oWord As ClassWord)
    Dim nActualFontSize As Single: nActualFontSize = nFontSize
    oWord.MoveToTop
    Do While oWord.Find(sFrom)                  '"From:"が見つかった
        If nFontSize <= 0 Then                  'フォントサイズを戻す場合
            oWord.SelectCharNum 1               '"From:"の先頭1文字を選択
            nActualFontSize = oWord.GetFontSize
        End If
        oWord.ExtendToTail
        oWord.CollapseEnd                       '"From:～"の次行へ
        ：
    Loop
    oWord.MoveToTop
End Sub

メールヘッダのループです。ヘッダのアイテム名末尾が「:」であることを前提として、アイテム名を切り出して、そのアイテム名で処理を分岐させます。
アイテム名が、"Sent", "送信日時"の時は、次の行まで読み飛ばします。
また、"To", "Cc", "CC", "宛先", "ＣＣ"の時は、改行文字までを選択してフォントサイズを変更します。
それ以外のアイテム名の時は、ループを終了します。

        Do
            oWord.ExtendUntilBeforeChars ":"    'ヘッダのアイテム名を選択
            Select Case oWord.GetText
                Case "Sent", "送信日時"
                    oWord.ExtendToTail
                    oWord.CollapseEnd           '"Sent～"の次行へ
                    
                Case "To", "Cc", "CC", "宛先", "ＣＣ"
                    oWord.ExtendToTail
                    oWord.SetFontSize nActualFontSize 'フォントサイズ変更
                    oWord.SetSimpleLine
                    oWord.CollapseEnd
                    
                Case Else
                    oWord.CollapseEnd
                    Exit Do                     '上記以外なら内側のループを終了
            End Select
        Loop

ClassWord.clsは、Word編集の機能を利用したクラスモジュールで、編集中のメールを処理します。各処理自体は、単純な文書の選択や検索などであり、主な関数ごとにコメントを付しているため、ここでの説明は省略します。（実は気の利いた関数名を付けられなかったので、コメントで捕捉しているところもあるのですが）(^_^;)