2019年7月9日 / 最終更新日時 : 2021年12月30日 officeの杜 msoffice

Accessで差込メールを送信する

事務の現場では、特定の要素に基づいて、個別にメールを作成し送る機会が意外と多いです。直近だけでも4件、同様の需要がありました。これらの要望にはこれまでは「Wordの差込印刷機能を利用して、指定のメーラーで送信する」といった、ノンプログラミングな手法が用いられてきていました。

しかし、この手法、社内にメールサーバを持っていたような昔だったら有効だったのですが、現代のように「クラウド」にしてしまっていた場合、送信制限に抵触してアカウントが凍結される恐れもあります。

例えば、Microsoft365の場合、

1分間に30通以上送信するとアウト
１日あたり10,000通以上のメール送信
1度に送れる送信先は500名まで
受診者のプロキシアドレス制限は400名まで
1メールあたり25MBまで（初期値） - 最大150MBまで管理者であれば拡張可能
添付ファイルのサイズは34MBまで。大容量ファイルBoxやOneDriveなどのリンクを公開し、パスワードを付与して送ると良い

特に1つ目の30通以上/1分間の制限が厳しく、差込印刷でメール送信をすると、軽くアカウント凍結されてしまいます。今回はこの課題をクリアしつつ、指定のメンバーへ個別のメールを送信してみたいと思います。（今回は1分間に20通送るようにしています）

1 今回使用するファイルやライブラリ
2 アプリの仕様
3 ソースコード
- 3.1 社員マスタデータのインポート
- 3.2 メールの一括送信
4 使い方の手順
5 関連リンク

今回使用するファイルやライブラリ

postman.7z - プログラム本体その他が入ってるサンプル
社員マスタテンプレート - インポート用のxlsxファイル

※今回のAccessアプリは64bit版として作成していますので、32bit版で動かすと不具合が出ると思います。

また、今回のアプリでは、以下のライブラリを利用しています。

Access Ribbon External Image Library - リボンのアイコンで独自画像を使う為のライブラリ
メールアドレス形式チェック - 正規表現でメアドの精査を行なう

アプリの仕様

今回のアプリケーションは、ユーザへ現在の定期券の登録データを個別に通知する為のプログラムです。以下のような仕様が含まれています。

社員マスタには社員のデータ、定期券のデータを用意しておく
通信文マスタは、送信するメールのヘッダや本文、署名、返信先アドレスなどを格納しておく。
Reply-Toに対応しており、返信先アドレスで送信元とは違う、グループアドレスを指定可能
通信文の新規追加・既存データの編集用ダイアログを用意
回答期限は「西暦 + 曜日」で表記する
メールはHTML形式とし、改行コードはすべて タグに変換して挿入する
既存の登録データは起動時に自動的に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 - メールアドレス形式確認で正規表現を使うために必要

ソースコード

社員マスタデータのインポート

'新しい社員マスタデータを持ってデータを更新する
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

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としてリンクテーブルを設定しています。
社員マスタテーブルを全削除⇒社員マスタへデータを追加という形で、洗い替えでデータを取り込んでいます。
マスタ編集画面が開かれていた場合、社員マスタのサブフォームを再読込するコードを最後に実行しています。

メールの一括送信

'メール一括送信メインルーチン
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

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("本文") & " "

'回答期限を日本語曜日付きに変換する

Dim kaitou As String

kaitou = Format(rst("回答期限"), "Long Date") & "(" & Format(rst("回答期限"), "aaa") & ")"

'メール・メッセージを取得

mailmsg = "【ご返信内容】" & rst("返信内容") & " " & _

"【回答期限】" & kaitou & " " & _

"" & rst("あとがき") & " " & _

"【担　当】" & rst("担当署名") & ""

'改行コードを に置き換え

body = Replace(body, vbLf, " ")

mailmsg = Replace(mailmsg, vbLf, " ")

'メールサブジェクトを取得

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("会社名") & " " & _

rsc("社員名") & "様 "

'定期券代をカンマ区切りに変換する

teiki = Format(rsc("定期代_6ヶ月"), "#,##0")

'現在登録内容を作成する

touroku = "【現在登録内容】" & "・乗車バス停：" & rsc("乗車バス停名") & " " & _

"・降車バス停：" & rsc("降車バス停名") & " " & _

"・定期券代　：" & teiki & " "

'送信先メアドを取得

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が必要です。

Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)

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のコード内にあります。

社員マスタおよび通信文マスタのデータをバックアップします。

Accessで差込メールを送信する

今回使用するファイルやライブラリ

アプリの仕様

ソースコード

社員マスタデータのインポート

メールの一括送信

使い方の手順

社員マスタデータの取り込み

通信文マスタのデータ作成

メールの一括送信

データのバックアップ

関連リンク

コメントを残すコメントをキャンセル

クエリを制する者はAccessを制する

Boxミニマニュアル

今回使用するファイルやライブラリ

アプリの仕様

ソースコード

社員マスタデータのインポート

メールの一括送信

使い方の手順

社員マスタデータの取り込み

通信文マスタのデータ作成

メールの一括送信

データのバックアップ

関連リンク

コメントを残す コメントをキャンセル

コメントを残すコメントをキャンセル