VBAより一覧データをCSS装飾してOutlookで送信
以前、Google Apps Scriptでレスポンシブメールを送るというものを実装したことがあります。CSSで綺麗な装飾をしたメールってだけではなく、PC用とスマフォ用とでメディアクエリも利用して、レスポンシブなメールを送るスクリプトです。自分が手掛けた社内向けの通知メールにはすでに実装済みで、リンクをクリックするとPC用だと承認フォームが開き、スマフォ用だとダイレクトにターゲットになる承認レコードの画面が出るといったように、URLも変えて送ってます。
さてこのメールですが、手動で作るのは大変です。ましてや、Outlookで作るとなると単純なメールであっても時間が掛かってしまいます。今回はVBAにてExcel上の受注データを予め設定しておいた送信先に、CSSで装飾をしてOutlook2016にて送り付ける小ネタプログラムを作ってみました。
リンク
今回使用するファイル
※あらかじめ、シートのメール設定に於いて、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
- 起動時にレジストリの値を呼び出すコードが入っています。
- 登録時には同じレジストリエントリに保存されます。
図：送信先メアド登録フォーム
メール送信メインコード
'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
- 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")
署名を添付する
Outlookを操作して新規メールを送る場合、設定済みのデフォルト署名がそのままでは挿入されません。また、署名データを取得するメソッドもないので、困ったものです。今回はExcelのセルに署名を記述してもらい、それを利用するようにしていますが、作成した署名自体は以下のディレクトリのテキストファイルに書かれています。
C:\Users\ユーザ名\AppData\Roaming\Microsoft\Signatures\xxxxx.txt
自分の場合、自分の名前を付けたtxtファイルがここに存在しており、これを読み込めるならば、プログラム側で使用署名を流用可能です。
実行結果
リボンよりサマリーメール送信を実行すると、送られます。GMailはもとよりOutlookでも、レスポンシブメールは対応済みなので、綺麗にCSSで装飾されたHTMLメールが送信されるはずです。CSSが使えるので、きめ細かな文字の装飾や、今回は実装しませんでしたが、メディアクエリを使ったPC/スマフォ用に表示を分けたメールの送信も可能でしょう。また、この方法は、Outlook自体を操作しているので、送信済みトレイに残るのも利点です。
図：個別に勤怠データを連続送信する時にも使えそうです。
