前回「VBA Outlook開発環境の整備」では、OutlookでVBAプログラムを開発するための準備を行いましたが、テストプログラムは無事動きましたでしょうか。今回は、その環境を使って、作成中のメールの宛名書きをするプログラムを作りたいと思います。

はじめに

業務用のメールを出す時など、メールのネチケットとして、メール本文の先頭に送り先の方の宛名をきちんと書き込んだりします。

メールをたまにしか出さないような人は、この宛名書きの作業も大して苦ではないと思いますが、様々な人に頻繁にメールを出すような方は、チリも積もればで結構な作業量となります。

でも、送信先に設定したアドレス情報には、その人の氏名や所属、役職など宛名書きに必要となる情報を含んでいるので、プログラムでそれらを引き出してメール本文に書き込んでやればよいわけです。

仕上がりイメージ

今回は、宛先に設定したアドレス情報から、苗字を取り出して「様」を付けてメール本文の先頭に書き込むプログラムを作成します。

プログラムを実行した時の仕上がりイメージは次のようになります。
クイックアクセスツールバーのコマンド（Project1.WriteName）ボタンを押すと、宛先に設定されたアドレス情報から苗字を取り出して「様」を付けてメール本文の先頭に書き込みます。

プログラムの作成

前回記事「VBA Outlook開発環境の整備」を参考にしながら、OutlookのVBEで「標準モジュール」を挿入します。オブジェクト名は以下とします。

(オブジェクト名)：ModuleWriteName

そのモジュールに次のプログラム（30行）を組み込みます。

Option Explicit

Public Sub WriteName()
    Dim oMailItem As MailItem: Set oMailItem = Application.ActiveInspector.CurrentItem
    Dim sNames As String: sNames = ""
    
    Dim oRecipient As Recipient
    For Each oRecipient In oMailItem.Recipients
        If oRecipient.Type = olTo Then
            Dim oAddress As Object: Set oAddress = GetAddress(oRecipient)
            If Not (oAddress Is Nothing) Then
                If sNames <> "" Then sNames = sNames & "、"
                sNames = sNames & oAddress.LastName & " 様"
            End If
        End If
    Next oRecipient
    
    oMailItem.Body = sNames & vbNewLine & oMailItem.Body
End Sub

Private Function GetAddress(oRecipient As Recipient) As Object
    Set GetAddress = Nothing
    On Error Resume Next
    
    Set GetAddress = oRecipient.AddressEntry.GetExchangeUser()
    If Not (GetAddress Is Nothing) Then Exit Function
    
    Set GetAddress = oRecipient.AddressEntry.GetContact()
    If Not (GetAddress Is Nothing) Then Exit Function
End Function

プログラムを書き込んだ後のVBEイメージです。

メッセージ編集ウィンドウを開いて、クイックアクセスツールバーにコマンド（Project1.WriteName）ボタンを追加します。

プログラムの動作確認

それでは組み込んだプログラムの動作を確認します。
ここでは、テスト用に作成した架空の名前のアドレス情報を利用しました。

メッセージ編集ウィンドウで、宛先に適当なアドレス情報を設定して、コマンド（Project1.WriteName）ボタンを押します。
宛先に設定したアドレス情報から取り出した「苗字」に「様」を付けた宛名が、メール本文の先頭に書き込まれれば動作は正常です。

プログラムの解説

プログラムの主な内容を説明します。

WriteNameは、宛名書きのメイン関数でコマンドボタンから呼び出されます。メッセージ編集ウィンドウで作成中のメールのMailItemオブジェクトを取り出します。また、宛名の文字列を格納する変数sNamesを宣言して空文字で初期化します。

Public Sub WriteName()
    Dim oMailItem As MailItem: Set oMailItem = Application.ActiveInspector.CurrentItem
    Dim sNames As String: sNames = ""

宛先に設定したアドレス情報をを１つずつ取り出すForループです。oRecipient.Typeをチェックして、宛先（olTo）だけを対象とし、CCやBCCは対象外とします。

    Dim oRecipient As Recipient
    For Each oRecipient In oMailItem.Recipients
        If oRecipient.Type = olTo Then
        ：
        End If
    Next oRecipient

受信先oRecipientからアドレス情報を取得し、さらにそこから苗字を取り出して複数人分を連結します。２人目以降の苗字を連結する前には、区切り文字「、」を追加します。

            Dim oAddress As Object: Set oAddress = GetAddress(oRecipient)
            If Not (oAddress Is Nothing) Then
                If sNames <> "" Then sNames = sNames & "、"
                sNames = sNames & oAddress.LastName & " 様"
            End If

メール本文の先頭に宛名を追加します。

    oMailItem.Body = sNames & vbNewLine & oMailItem.Body

GetAddressは、受信先oRecipientからアドレス情報を取得します。
まずは、Exchangeのグローバルアドレス一覧へ取りにいき、もしそこになければ、連絡帳へ取りにいきます。

Private Function GetAddress(oRecipient As Recipient) As Object
    Set GetAddress = Nothing
    On Error Resume Next
    
    Set GetAddress = oRecipient.AddressEntry.GetExchangeUser()
    If Not (GetAddress Is Nothing) Then Exit Function
    
    Set GetAddress = oRecipient.AddressEntry.GetContact()
    If Not (GetAddress Is Nothing) Then Exit Function
End Function

さいごに

メールの宛名書きをする簡単なプログラムを作成しました。

今回は苗字に様付けをする宛名書きでしたが、アドレス情報には苗字以外にも名前や所属、役職などの情報も含んでおり、メールの送信先や送る目的などによって、それらの情報も組み合わせて宛名を作成できると応用範囲が広がります。
また、テキスト形式のメールの場合は問題ないのですが、HTML形式などでフォントや文字色を変えている場合は、その書式で宛名が書き込まれない不都合があります。

次回はそのあたりの改良を加えたプログラムを作成しようと考えています。