Accessで差込メールを送信する
事務の現場では、特定の要素に基づいて、個別にメールを作成し送る機会が意外と多いです。直近だけでも4件、同様の需要がありました。これらの要望にはこれまでは「Wordの差込印刷機能を利用して、指定のメーラーで送信する」といった、ノンプログラミングな手法が用いられてきていました。
しかし、この手法、社内にメールサーバを持っていたような昔だったら有効だったのですが、現代のように「クラウド」にしてしまっていた場合、送信制限に抵触してアカウントが凍結される恐れもあります。
例えば、Microsoft365の場合、
- 1分間に30通以上送信するとアウト
- １日あたり10,000通以上のメール送信
- 1度に送れる送信先は500名まで
- 受診者のプロキシアドレス制限は400名まで
- 1メールあたり25MBまで（初期値） - 最大150MBまで管理者であれば拡張可能
- 添付ファイルのサイズは34MBまで。大容量ファイルBoxやOneDriveなどのリンクを公開し、パスワードを付与して送ると良い
特に1つ目の30通以上/1分間の制限が厳しく、差込印刷でメール送信をすると、軽くアカウント凍結されてしまいます。今回はこの課題をクリアしつつ、指定のメンバーへ個別のメールを送信してみたいと思います。（今回は1分間に20通送るようにしています）
リンク
目次
今回使用するファイルやライブラリ
- postman.7z - プログラム本体その他が入ってるサンプル
- 社員マスタテンプレート - インポート用のxlsxファイル
※今回のAccessアプリは64bit版として作成していますので、32bit版で動かすと不具合が出ると思います。
また、今回のアプリでは、以下のライブラリを利用しています。
- Access Ribbon External Image Library - リボンのアイコンで独自画像を使う為のライブラリ
- メールアドレス形式チェック - 正規表現でメアドの精査を行なう
アプリの仕様
今回のアプリケーションは、ユーザへ現在の定期券の登録データを個別に通知する為のプログラムです。以下のような仕様が含まれています。
- 社員マスタには社員のデータ、定期券のデータを用意しておく
- 通信文マスタは、送信するメールのヘッダや本文、署名、返信先アドレスなどを格納しておく。
- Reply-Toに対応しており、返信先アドレスで送信元とは違う、グループアドレスを指定可能
- 通信文の新規追加・既存データの編集用ダイアログを用意
- 回答期限は「西暦 + 曜日」で表記する
- メールはHTML形式とし、改行コードはすべて<br>タグに変換して挿入する
- 既存の登録データは起動時に自動的に5世代バックアップを行う
- 任意のタイミングで既存データをZIP形式でバックアップ・復元出来る機能を付けておく（7zip64.dll対応）
- メールの連続送信は、Outlookを直接操作し、1通送る毎に3秒間のウェイトを掛けるようにしています。
また、今回のプログラムは以下の参照設定（事前バインディング）を入れています。
- Microsoft Office 16.0 Object Library - Accessのリボンコントロール、FileDialogの呼び出しで必要
- Microsoft Outlook 16.0 Object Library - Outlook 2019を遠隔操作するために必要
- Microsoft Scripting Runtime - ファイルの存在確認などでFilesystem Objectを使うために必要
- Microsoft VBScript Regular Expressions 5.5 - メールアドレス形式確認で正規表現を使うために必要
ソースコード
社員マスタデータのインポート
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 |
'新しい社員マスタデータを持ってデータを更新する Public Function newemp_import() Dim strpath As String Dim ret As Integer 'ファイルを開くダイアログ用 Dim dlg As Object, boolResult As Boolean Dim strFiles As String, i As Long Dim myStr As String 'オブジェクト変数にFileDialogオブジェクトを代入 Set dlg = Application.FileDialog(msoFileDialogSaveAs) With Application.FileDialog(msoFileDialogFilePicker) '複数選択可能かを設定 .AllowMultiSelect = False 'ファイル ダイアログ ボックスのタイトル設定 .title = "社員マスタデータのインポート" '表示される初期パスまたはファイル名を設定 .InitialFileName = CreateObject("WScript.Shell").SpecialFolders.Item("Desktop") & "" '初期ビューを設定(バージョンによって無視される) .InitialView = msoFileDialogViewWebView 'ファイル フィルタのコレクション追加 With .filters .Clear .Add "社員マスタ", "*.xls;*.xlsx" End With 'Showを宣言した所でダイアログが開かれる。戻り値は以下の通り 'ファイル、フォルダが選択 → True 'キャンセルを押された → False If .Show = True Then myStr = .SelectedItems(1) strpath = myStr Else myStr = "" MsgBox "キャンセルされました。" Exit Function End If End With 'ファイルパスを渡す ret = renewimport(strpath) End Function '新社員マスタデータを持ってデータを更新するルーチン Function renewimport(targetdbpath As String) As Integer On Error Resume Next Dim foldername As Variant Dim FileName As String Dim result As Variant Dim fieldcnt As Variant Dim strSQL As Variant Dim varRet As Variant 'DB接続用の変数宣言 Dim db As DAO.Database Set db = CurrentDb Dim tdf As DAO.TableDef '該当レコードが処理済みになってる場合問い合わせをする result = MsgBox("選択した社員マスタデータでデータを取り込みますか？既存の社員マスタデータは最新のデータに上書きされますよ？？", vbYesNo + vbDefaultButton2 + vbExclamation) If result = vbYes Then 'インポート処理を続行する Else 'メッセージを表示 MsgBox "データのインポートをキャンセルしました。" '終了処理 db.Close: Set db = Nothing Set tbf = Nothing Exit Function End If '念の為リンクテーブルを解除しておく DoCmd.DeleteObject acTable, "m_employee" 'テーブルリンクを作成する DoCmd.TransferSpreadsheet acLink, , "m_employee", targetdbpath, True, "対象者一覧!" '警告ダイアログをON(戻す) DoCmd.SetWarnings False '社員マスタを全削除する DoCmd.OpenQuery "社員マスタ全削除" 'データ追加クエリを実行する DoCmd.OpenQuery "社員マスタ差分追加" '警告ダイアログをON(戻す) DoCmd.SetWarnings True 'リンクテーブルを解除する DoCmd.DeleteObject acTable, "m_employee" '終了処理 MsgBox "社員マスタの更新と差分の追加が完了しました。" 'マスタ編集が開かれていたら、社員マスタサブフォームをリロードする If SysCmd(acSysCmdGetObjectState, acForm, "マスタ編集") <> 0 Then '開いているので、社員マスタのサブフォームをリロード Forms!マスタ編集!subform.Requery Else '開いていないので何もしない End If 'オブジェクトの開放 db.Close: Set db = Nothing Set tbf = Nothing End Function |
- FileDialogにて用意しておいたxlsxのリストにリンクテーブルを張っています。
- xlsxファイルのパスは、renewimportの処理へ送られ、ここで実際のメインの処理が実行される仕組みです。
- 対象者一覧シートをm_employeeとしてリンクテーブルを設定しています。
- 社員マスタテーブルを全削除⇒社員マスタへデータを追加という形で、洗い替えでデータを取り込んでいます。
- マスタ編集画面が開かれていた場合、社員マスタのサブフォームを再読込するコードを最後に実行しています。
メールの一括送信
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 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 148 149 150 151 152 |
'メール一括送信メインルーチン Private Sub コマンド3_Click() '通常の変数の宣言 Dim result As Variant '選択項目のIDを取得する Dim seleid As Variant seleid = Me.connid.value '選択項目が空の場合 If seleid = "" Or IsNull(seleid) Then MsgBox "通信文が選択されていませんよ。" Exit Sub End If '処理実行の確認 result = MsgBox("指定の内容で、メールを一括送信しますか？。", vbYesNo + vbDefaultButton2 + vbCritical, "メールの連続送信") If result = vbYes Then 'DB接続用変数 Dim db As DAO.Database Dim rst As DAO.Recordset Dim rsc As DAO.Recordset Set db = CurrentDb Dim strSQL As String Else '処理のキャンセル MsgBox "処理はキャンセルされました。" Exit Sub End If 'IDを元にレコードデータを抽出 strSQL = "SELECT * FROM 通信文マスタ WHERE ID=" & seleid 'レコードセットをセットする Set rst = db.OpenRecordset(strSQL) Set rsc = db.OpenRecordset("社員マスタ") '送信メッセージの組み立て Dim body As Variant Dim henshin As Variant Dim limitday As Variant Dim atogaki As Variant Dim signature As Variant Dim replyto As Variant Dim subject As String Dim mailmsg As Variant '本文の取得 body = rst("本文") & "<br><br>" '回答期限を日本語曜日付きに変換する Dim kaitou As String kaitou = Format(rst("回答期限"), "Long Date") & "(" & Format(rst("回答期限"), "aaa") & ")" 'メール・メッセージを取得 mailmsg = "<p><b>【ご返信内容】</b></p>" & rst("返信内容") & "<br><br>" & _ "<p><b>【回答期限】</b></p>" & kaitou & "<br><br>" & _ "<p>" & rst("あとがき") & "</p><br><br>" & _ "<p><b>【担 当】</b></p>" & rst("担当署名") & "</p>" '改行コードを<br>に置き換え body = Replace(body, vbLf, "<br>") mailmsg = Replace(mailmsg, vbLf, "<br>") 'メールサブジェクトを取得 subject = rst("件名") '返信先を取得 replyto = rst("返信先アドレス") '返信先アドレスの有無をチェックする If replyto = "" Or IsNull(replyto) Then MsgBox "返信先アドレスが空っぽですよ。" Exit Sub End If If chkMailAddress(CStr(replyto)) Then Else MsgBox "返信先アドレスがメールアドレスの形式ではないようです" Exit Sub End If 'ウェイトタイムを取得する Dim sleepwait As Variant sleepwait = rst("ウェイト") '個別データを回しながら１通ずつメールを送信 Dim mailhead As String Dim touroku As String Dim mailman As String Dim teiki As String 'Outlookオブジェクトの生成 Dim objOutlook As Outlook.Application Dim objMail As Outlook.MailItem 'MailItemオブジェクトを生成 Set objOutlook = New Outlook.Application Do Until rsc.EOF 'メール作成インスタンスの作成 Set objMail = objOutlook.CreateItem(olMailItem) 'メールヘッダを作成する mailhead = rsc("会社名") & "<br>" & _ rsc("社員名") & "様<br><br><br>" '定期券代をカンマ区切りに変換する teiki = Format(rsc("定期代_6ヶ月"), "#,##0") '現在登録内容を作成する touroku = "<p><b>【現在登録内容】</b></p>" & "・乗車バス停：" & rsc("乗車バス停名") & "<br>" & _ "・降車バス停：" & rsc("降車バス停名") & "<br>" & _ "・定期券代 ：" & teiki & "<br><br><br>" '送信先メアドを取得 mailman = rsc("メールアドレス") 'メールを組み立てる（HTMLメール形式） With objMail .To = mailman .subject = subject .BodyFormat = olFormatHTML 'メールの形式 .ReplyRecipients.Add replyto .HTMLBody = mailhead & body & touroku & mailmsg 'メール本文 'メールを送信する .Send End With '指定秒数ウェイト Sleep sleepwait '次のレコードへ移動 rsc.MoveNext Loop '終了メッセージ Set objOutlook = Nothing MsgBox "メールの送信が完了しました。" '終了処理 DoCmd.Close acForm, Me.Name '終了処理 Set rst = Nothing Set rsc = Nothing Set db = Nothing End Sub |
- 一括送信ダイアログの送信ボタンを実行した時に発動するコードです。
- ダイアログのコンボボックスの選択されているIDを元に、通信文マスタのデータを取り出します。
- 回答期限についてはFormat関数にて西暦+曜日表記に、定期代についてはFormat関数にてカンマ区切りにして変換を掛けています。
- chkMailAddress関数にて簡易的に「メールアドレス形式のチェック」を行っています。
- 返信先アドレスが空の場合には送信できないようにしてあります。
- .ReplyRecipients.Addオプションにて、Reply-To(返信先アドレス)を設定可能です。
- BodyFormatをolFormatHTMLにした場合には、HTMLメールなのでBodyではなくHTMLBodyで指定しなければなりません。
- 今回は送信時に指定秒数間のスリープを入れて、Microsoft365の制限を回避させている為、Declare FunctionにSleepが必要です。
|
1 |
Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr) |
使い方の手順
本プログラムは社員マスタおよび事前に用意しておいた通信文のフォーマットに従って、メールで通知するプログラムですので、決められた手順でデータの準備と送信を行わなければなりません。
社員マスタデータの取り込み
添付の社員マスタテンプレートにデータを準備しておきます。会社メールアドレスの列については間違えのないように。このアドレスをToとして利用します。
準備が整ったら、
- リボンの「メール送信」タブを開く
- データのインポートにある「社員マスタ取り込み」をクリック。
- 用意しておいたxlsxファイルを指定すると取り込み開始
- 取り込みが完了したら、社員マスタテーブルにデータがInsertされます。
通信文マスタのデータ作成
通信文とは、メールに差し込む元になるテンプレートなデータです。用途に応じて用意しておくと良いでしょう。各項目は以下のような使われ方をします。
- 通信文名 - 一括送信時にコンボボックスに出てくるリストの名前
- 件名 - メール送信時のSubject項目として利用される。
- 本文 - メールの冒頭本文にあたります。改行はすべてBRタグに変換されますので、見た目のままメールに差し込まれます。
- 返信内容 - 本文と同様
- 回答期限 - 西暦カレンダーで選択が可能。実際に差し込まれる時は、西暦 + 曜日での表現に変換されます。
- あとがき - ここは無理に入れなくても良いですが、「よろしくお願い申し上げます」的なメッセージを入れておくと無難でしょう。
- 担当署名 - 通常は送信者の署名を入れておきますが、返信先アドレスがグループアドレスならば、グループに従った署名を入れておくと良いでしょう。
- ウェイト - デフォルトは300msで決め撃ちです。
- 返信先アドレス - FROMと同じアドレスを入れてもOKです。空だと登録はできません。相手が返信をクリックするとToに表示されるアドレスを登録しておきます。
図：通信文編集用ダイアログの表示例
メールの一括送信
社員マスタのメンバーに対して、メールを送信します。通信文マスタで設定しておいた内容をここでロードし送信しますが、返信先アドレスが設定されていない時には、送信ができませんのでご注意ください。
図：メール一括送信ダイアログ
データのバックアップ
本体プログラムであるpostman.accdbを起動すると、データ保存場所であるdatabase.accdbのバックアップを5世代に渡って自動で作成します。古いものは自動で其の際に削除されます。このバックアップとは別に、任意のタイミングでZIP形式で取れるのが、データのバックアップ。暗号化ZIPとなっているので、バックアップファイルはパスワードを入力しないと解凍できません。
デフォルトパスワードはpleasemrpostmanとなっていて、VBAのコード内にあります。
社員マスタおよび通信文マスタのデータをバックアップします。
関連リンク
- マクロでメール送信 - エクセルの学校
- 【VBA入門】Sleep関数(API)やWaitメソッドで処理を止める方法
- メッセージの受信を通知するマクロ
- ReplyRecipients プロパティ (Outlook)
- Excelマクロで生成したOutlookメールに差出人とは別の返信先を指定したい
- Exchange Online の制限
