2019年4月8日 / 最終更新日時 : 2021年12月30日 officeの杜 Microsoft365

VBAより一覧データをCSS装飾してOutlookで送信

以前、Google Apps Scriptでレスポンシブメールを送るというものを実装したことがあります。CSSで綺麗な装飾をしたメールってだけではなく、PC用とスマフォ用とでメディアクエリも利用して、レスポンシブなメールを送るスクリプトです。自分が手掛けた社内向けの通知メールにはすでに実装済みで、リンクをクリックするとPC用だと承認フォームが開き、スマフォ用だとダイレクトにターゲットになる承認レコードの画面が出るといったように、URLも変えて送ってます。

さてこのメールですが、手動で作るのは大変です。ましてや、Outlookで作るとなると単純なメールであっても時間が掛かってしまいます。今回はVBAにてExcel上の受注データを予め設定しておいた送信先に、CSSで装飾をしてOutlook2016にて送り付ける小ネタプログラムを作ってみました。

1 今回使用するファイル
2 ソースコード
3 実行結果
4 関連リンク

今回使用するファイル

※あらかじめ、シートのメール設定に於いて、Subject, Body, Footer, Creditにそれぞれメールタイトル、本文上部、フッター、署名を入力しておく必要があります。セル内改行はそのまま<br>タグに置き換わりますので、見た目の通りに反映されるようになっています。また、事前にリボンにあるアプリケーション設定から、送信先とCCのメアドを登録しておく必要があります。

ソースコード

メアド登録用フォームのコード

今回の送信プログラムは、ToとCCの二つを登録して、そのメアドを元に自動送信を実現しています。データはレジストリに登録されるので、ファイルはユーザ事に設定が必要になります。

Private Sub CommandButton1_Click()
    '入力内容を取得する
    Dim apikey As String
    Dim apitoken As String
    Dim sendto As String
    Dim sendcc As String
    Dim lRet As Variant

    sendto = Me.TextBox3.Value
    sendcc = Me.TextBox4.Value
    
    '入力内容でもってレジストリにデータを登録
    lRet = RegSetValue(HKEY_CURRENT_USER, _
           "Software\cr" & _
           "\Settings", _
           "sendto", _
           REG_SZ, _
           sendto)

    lRet = RegSetValue(HKEY_CURRENT_USER, _
           "Software\cr" & _
           "\Settings", _
           "sendcc", _
           REG_SZ, _
           sendcc)
    
    'フォームを閉じる
    Unload UserForm1
    
End Sub
'UserFormがロードされた時に発動
Private Sub UserForm_Initialize()
    'レジストリ項目をボックスにロードする
    On Error Resume Next
    'レジストリからIDとパスワードを読み取る
    Dim sendto As String
    Dim sendcc As String
    
    sendto = RegGetValue(HKEY_CURRENT_USER, _
            "Software\cr" & _
            "\Settings", _
            "sendto", _
            REG_SZ, _
            0)

    sendcc = RegGetValue(HKEY_CURRENT_USER, _
            "Software\cr" & _
            "\Settings", _
            "sendcc", _
            REG_SZ, _
            0)

    Me.TextBox3.Value = sendto
    Me.TextBox4.Value = sendcc

End Sub

'登録用モーダルウィンドウの表示
Public Function openModal()

    '設定用のモーダルウィンドウを表示
    UserForm1.Show vbModal

End Function

Private Sub CommandButton1_Click()

'入力内容を取得する

Dim apikey As String

Dim apitoken As String

Dim sendto As String

Dim sendcc As String

Dim lRet As Variant

sendto = Me.TextBox3.Value

sendcc = Me.TextBox4.Value

'入力内容でもってレジストリにデータを登録

lRet = RegSetValue(HKEY_CURRENT_USER, _

"Software\cr" & _

"\Settings", _

"sendto", _

REG_SZ, _

sendto)

lRet = RegSetValue(HKEY_CURRENT_USER, _

"Software\cr" & _

"\Settings", _

"sendcc", _

REG_SZ, _

sendcc)

'フォームを閉じる

Unload UserForm1

End Sub

'UserFormがロードされた時に発動

Private Sub UserForm_Initialize()

'レジストリ項目をボックスにロードする

On Error Resume Next

'レジストリからIDとパスワードを読み取る

Dim sendto As String

Dim sendcc As String

sendto = RegGetValue(HKEY_CURRENT_USER, _

"Software\cr" & _

"\Settings", _

"sendto", _

REG_SZ, _

sendcc = RegGetValue(HKEY_CURRENT_USER, _

"Software\cr" & _

"\Settings", _

"sendcc", _

REG_SZ, _

Me.TextBox3.Value = sendto

Me.TextBox4.Value = sendcc

End Sub

'登録用モーダルウィンドウの表示

Public Function openModal()

'設定用のモーダルウィンドウを表示

UserForm1.Show vbModal

End Function

起動時にレジストリの値を呼び出すコードが入っています。
登録時には同じレジストリエントリに保存されます。

図：送信先メアド登録フォーム

メール送信メインコード

'Outlookを起動しメールを作成するルーチン
Public Function mailapp()
    Dim result As Variant

    '問い合わせ
    result = MsgBox("取り込んだ予約データをもとにサマリーメールを送りますか？", vbYesNo + vbDefaultButton2 + vbExclamation)
    If result = vbYes Then
        '次の処理に進む
    Else
        MsgBox "メール送信はキャンセルされました。"
        Exit Function
    End If

    'メール用パーツデータを取得する
    Dim subjectman As String
    Dim body As String
    Dim footerman  As String
    Dim css As String
    Dim credit As String
    
    subjectman = Worksheets("メール設定").Range("B1").Value
    body = Worksheets("メール設定").Range("B2").Value
    footerman = Worksheets("メール設定").Range("B3").Value
    credit = Worksheets("メール設定").Range("B4").Value
    css = Worksheets("メール設定").Range("B5").Value
    
    '改行コードを<br>にリプレース
    body = Replace(body, vbLf, "<br>")
    footerman = Replace(footerman, vbLf, "<br>")
    credit = Replace(credit, vbLf, "<br>")
    
    'レジストリより送信先を取得する
    Dim sendto As String
    Dim sendcc As String
    
    sendto = RegGetValue(HKEY_CURRENT_USER, _
            "Software\cr" & _
            "\Settings", _
            "sendto", _
            REG_SZ, _
            0)

    sendcc = RegGetValue(HKEY_CURRENT_USER, _
            "Software\cr" & _
            "\Settings", _
            "sendcc", _
            REG_SZ, _
            0)
    
    'メール用データを取得
    Dim dataArray
    Dim lastrow As Long
    Dim i As Long
        
    '予約データの最終行を取得
    lastrow = Worksheets("予約データ").UsedRange.Rows.Count

    'データを取得する
    If lastrow = 1 Then
        MsgBox "送信するべきデータがありませんよ。"
        Exit Function
    Else
        dataArray = Worksheets("予約データ").Range("A2:R" & lastrow)
    End If
    
    '送信するサマリーデータを組み立て
    'テーブルヘッダーの構築とCSSねじこみ
    Dim formbody As String
    Dim csshead As String
    Dim cssfoot As String
    Dim tableth As String
    
    csshead = "<head><style>"
    cssfoot = "</style></head>"
    tableth = "<body><table class='type08'><thead><tr>" & _
              "<th>日付</th>" & _
              "<th>時間</th>" & _
              "<th>部署名</th>" & _
              "<th>来室者</th>" & _
              "<th>続柄</th>" & _
              "<th>性別</th>" & _
              "<th>職籍</th>" & _
              "<th>新規継続</th>"
    
    'サマリーデータの生成
    Dim cnt As Long
    Dim kananame As String
    cnt = 1
    
    For i = 2 To lastrow
        '入力値が空の場合、スルーする
        If dataArray(cnt, 2) = "" Or IsNull(dataArray(cnt, 2)) Then
            'スルーする
        Else
            'カナの頭だけ取った名前を構成
            kananame = Left(dataArray(cnt, 15), 1) & "・" & Left(dataArray(cnt, 16), 1) & "さん"
        
            '入力値からテーブルを構成
            tableth = tableth & "<tr>"
        
            tableth = tableth & "<td>" & dataArray(cnt, 5) & "</td>" & _
                                "<td>" & Format(CDate(dataArray(cnt, 6)), "HH:MM") & "</td>" & _
                                "<td>" & dataArray(cnt, 10) & "</td>" & _
                                "<td>" & kananame & "</td>" & _
                                "<td>" & dataArray(cnt, 8) & "</td>" & _
                                "<td>" & dataArray(cnt, 4) & "</td>" & _
                                "<td>" & dataArray(cnt, 17) & "</td>" & _
                                "<td>" & dataArray(cnt, 18) & "</td>"

            tableth = tableth & "</tr>"
        
        End If
    
        'カウンタを加算する
        cnt = cnt + 1
    
    Next i
    
    'メールパーツを組み立てる
    tableth = tableth & "</tbody></table></body>"
    formbody = csshead & css & cssfoot & body & "<br><br>" & tableth & "<br><br>" & footerman & "<br><br>" & credit


    'Outlookオブジェクトの生成
    Dim objOutlook As Outlook.Application
    Dim objMail As Outlook.MailItem
    
    'MailItemオブジェクトを生成
    Set objOutlook = New Outlook.Application
    Set objMail = objOutlook.CreateItem(olMailItem)

    'メールを組み立てる
    With objMail
        .To = sendto  'メール宛先(To)
        .CC = sendfcc 'メール宛先(CC)
        .Subject = subjectman  'メール件名
        .BodyFormat = olFormatHTML  'メールの形式
        .HTMLBody = formbody
        'メールを送信する
        .Send
    End With
    
    '終了処理
    Set objOutlook = Nothing
    MsgBox "メールで通知しました。"
    
End Function

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

'Outlookを起動しメールを作成するルーチン

Public Function mailapp()

Dim result As Variant

'問い合わせ

result = MsgBox("取り込んだ予約データをもとにサマリーメールを送りますか？", vbYesNo + vbDefaultButton2 + vbExclamation)

If result = vbYes Then

'次の処理に進む

Else

MsgBox "メール送信はキャンセルされました。"

Exit Function

End If

'メール用パーツデータを取得する

Dim subjectman As String

Dim body As String

Dim footerman As String

Dim css As String

Dim credit As String

subjectman = Worksheets("メール設定").Range("B1").Value

body = Worksheets("メール設定").Range("B2").Value

footerman = Worksheets("メール設定").Range("B3").Value

credit = Worksheets("メール設定").Range("B4").Value

css = Worksheets("メール設定").Range("B5").Value

'改行コードを<br>にリプレース

body = Replace(body, vbLf, "<br>")

footerman = Replace(footerman, vbLf, "<br>")

credit = Replace(credit, vbLf, "<br>")

'レジストリより送信先を取得する

Dim sendto As String

Dim sendcc As String

sendto = RegGetValue(HKEY_CURRENT_USER, _

"Software\cr" & _

"\Settings", _

"sendto", _

REG_SZ, _

sendcc = RegGetValue(HKEY_CURRENT_USER, _

"Software\cr" & _

"\Settings", _

"sendcc", _

REG_SZ, _

'メール用データを取得

Dim dataArray

Dim lastrow As Long

Dim i As Long

'予約データの最終行を取得

lastrow = Worksheets("予約データ").UsedRange.Rows.Count

'データを取得する

If lastrow = 1 Then

MsgBox "送信するべきデータがありませんよ。"

Exit Function

Else

dataArray = Worksheets("予約データ").Range("A2:R" & lastrow)

End If

'送信するサマリーデータを組み立て

'テーブルヘッダーの構築とCSSねじこみ

Dim formbody As String

Dim csshead As String

Dim cssfoot As String

Dim tableth As String

csshead = "<head><style>"

cssfoot = "</style></head>"

tableth = "<body><table class='type08'><thead><tr>" & _

"<th>日付</th>" & _

"<th>時間</th>" & _

"<th>部署名</th>" & _

"<th>来室者</th>" & _

"<th>続柄</th>" & _

"<th>性別</th>" & _

"<th>職籍</th>" & _

"<th>新規継続</th>"

'サマリーデータの生成

Dim cnt As Long

Dim kananame As String

cnt = 1

For i = 2 To lastrow

'入力値が空の場合、スルーする

If dataArray(cnt, 2) = "" Or IsNull(dataArray(cnt, 2)) Then

'スルーする

Else

'カナの頭だけ取った名前を構成

kananame = Left(dataArray(cnt, 15), 1) & "・" & Left(dataArray(cnt, 16), 1) & "さん"

'入力値からテーブルを構成

tableth = tableth & "<tr>"

tableth = tableth & "<td>" & dataArray(cnt, 5) & "</td>" & _

"<td>" & Format(CDate(dataArray(cnt, 6)), "HH:MM") & "</td>" & _

"<td>" & dataArray(cnt, 10) & "</td>" & _

"<td>" & kananame & "</td>" & _

"<td>" & dataArray(cnt, 8) & "</td>" & _

"<td>" & dataArray(cnt, 4) & "</td>" & _

"<td>" & dataArray(cnt, 17) & "</td>" & _

"<td>" & dataArray(cnt, 18) & "</td>"

tableth = tableth & "</tr>"

End If

'カウンタを加算する

cnt = cnt + 1

Next i

'メールパーツを組み立てる

tableth = tableth & "</tbody></table></body>"

formbody = csshead & css & cssfoot & body & "<br><br>" & tableth & "<br><br>" & footerman & "<br><br>" & credit

'Outlookオブジェクトの生成

Dim objOutlook As Outlook.Application

Dim objMail As Outlook.MailItem

'MailItemオブジェクトを生成

Set objOutlook = New Outlook.Application

Set objMail = objOutlook.CreateItem(olMailItem)

'メールを組み立てる

With objMail

.To = sendto 'メール宛先(To)

.CC = sendfcc 'メール宛先(CC)

.Subject = subjectman 'メール件名

.BodyFormat = olFormatHTML 'メールの形式

.HTMLBody = formbody

'メールを送信する

.Send

End With

'終了処理

Set objOutlook = Nothing

MsgBox "メールで通知しました。"

End Function

Google Apps Scriptの時と同じようにCSSはセルに保存したものを呼び出し、<head>と<style>タグによって、メール本文冒頭に加えています。
メール本文上部およびフッター、署名は改行コード（vbLf）を<br>タグにリプレースしています。
時刻データはFormat関数によって、成形してあげないとシリアル値になっているので、具合が悪いので注意。
メール送信メソッドでは、BodyFormatはolFormatHTMLとし、BodyではなくHTMLBodyを利用する点に注意。テキストにすると、CSSの効かないメールになってしまいます。
今回のCSSは前回同様こちらのサイトからお借りしています。
予約データをTableでくみ上げてFormbodyとしています。
Outlook自体はバックグラウンドで動作するので本VBAを動かしても表示はされません。
昔のようなメールサーバに接続して送信させているわけではないので、余計な接続情報等不要でメールが送れるのが便利ですね。
Set objOutlook = New Outlook.Applicationとしているので、Microsoft Outlook 16.0 Object Library他の参照設定が必要です。2016より前のOutlookを使ってる場合には、以下のコードに置き換えてください。

Dim objOutlook As Object
Set objOutlook = CreateObject("Outlook.Application")

1 2	Dim objOutlook As Object Set objOutlook = CreateObject("Outlook.Application")

署名を添付する

Outlookを操作して新規メールを送る場合、設定済みのデフォルト署名がそのままでは挿入されません。また、署名データを取得するメソッドもないので、困ったものです。今回はExcelのセルに署名を記述してもらい、それを利用するようにしていますが、作成した署名自体は以下のディレクトリのテキストファイルに書かれています。

C:\Users\ユーザ名\AppData\Roaming\Microsoft\Signatures\xxxxx.txt

自分の場合、自分の名前を付けたtxtファイルがここに存在しており、これを読み込めるならば、プログラム側で使用署名を流用可能です。

実行結果

リボンよりサマリーメール送信を実行すると、送られます。GMailはもとよりOutlookでも、レスポンシブメールは対応済みなので、綺麗にCSSで装飾されたHTMLメールが送信されるはずです。CSSが使えるので、きめ細かな文字の装飾や、今回は実装しませんでしたが、メディアクエリを使ったPC/スマフォ用に表示を分けたメールの送信も可能でしょう。また、この方法は、Outlook自体を操作しているので、送信済みトレイに残るのも利点です。