ニーズの高いメールの一括配信処理ですが、お手軽にできる方法がなんだかパッとしません。※私が見つけられていないだけかもですが。。。
いろいろ検索してもVBAからメールソフトを利用する方法だったり、やり方が詳しく書かれていなかったりで、結局メールソフトで１件１件送っていたりします。
「先日も一覧表でメールアドレスのわかる方には一括でメールを送りたい！添付ファイルも付けたい！」と相談されておりました。
今までその方はWindowsソフトの”メールディストリビューター？”なるものを駆使して配信されておりましたが、配信先が変わるたび操作に手間取っていたので何とかしたいと思いややしばらくの間考えておりました。
ある日、ふと思い出しました。あ！ BASP21 使えるかも！
随分昔に何かでつかっており、久々にBASP21のサイトを見たらまだ公開されておりました。（⌒ω⌒）良かった～
ASPの VBScript やVisual Basic、EXCEL VBA WSH(Windows Scripting Host)などから使える汎用のコンポーネントです。
というわけでEXCEL VBAを使って作成しました。
機能
- メール配信先一覧シートよりメールアドレスの入力がある方に対して一括でメール配信します。
- あらかじめ５種類の文章（タイトル・本文・署名）を用意して送信時に切り替えられます。
- メール本文中に会社名・部署名・名前を差し込めます。
- 添付ファイルを複数添付できます。
動作確認
EXCEL2010 32ビット版
2020/05/11追記 64ビット版はこちらをご利用ください。
準備
BASP21のダウンロードとインストール
こちらのサイト BASP21 より以下の矢印を付けたファイルをダウンロードします。
basp21-2003-0211.exe を実行して画面の指示に従ってインストールを完了します。
bsmtp20070629-587.lzh を解凍して、現れた２つのファイル（Bsendm.exeとBsmtp.dll）を C:\Windows\System32 へ上書きコピーします。
メール配信用EXCELの準備
基本的に自由なレイアウトで作成していただいて良いと思います。私はこんな感じにしました。
作るのめんどくさい方はこちらからダウンロードしてください。
ご利用の際には、左上のメール設定を行ってから、校閲＞シートの保護でパスワード設定してください。件名・本文・署名はシート保護後も編集可能です。
VBAの説明
メール送信シート
- 添付ファイルを付けるための処理を記述します。添付ファイルボタン名はcmdFile1～5としてます。
- また添付ファイルボタン横のテキストボックス名はtxtFile1～5としてます。
- ファイルは複数添付出来ますが、添付ファイルをクリアするようにしてあるので、一度にまとめて選択しないといけません。
|
1 |
Private Sub cmdFile1_Click() Call cmdFile(txtFile1.Object) End Sub Private Sub cmdFile2_Click() Call cmdFile(txtFile2.Object) End Sub Private Sub cmdFile3_Click() Call cmdFile(txtFile3.Object) End Sub Private Sub cmdFile4_Click() Call cmdFile(txtFile4.Object) End Sub Private Sub cmdFile5_Click() Call cmdFile(txtFile5.Object) End Sub Private Sub cmdFile(txt As Object) On Error GoTo ErrHandler With Application.FileDialog(msoFileDialogOpen) ''ボタンのテキストを[Select]にします .ButtonName = "選択" .AllowMultiSelect = True .Title = "添付ファイルの選択" With .Filters ''「ファイルの種類」をクリアします .Clear ''「ファイルの種類」を登録します .Add "ドキュメント", "*.xls; *.xlsx; *.doc; *.docx", 1 .Add "すべてのファイル", "*.*", 2 End With ''表示するフォルダを指定します .InitialFileName = "C:\" ''表示するアイコンの大きさを指定します。 .InitialView = msoFileDialogViewLargeIcons If .Show = True Then ''有効なボタンがクリックされた txt.Text = "" For Each f In .SelectedItems ''テキストボックスに出力します If txt.Text = "" Then txt.Text = f Else txt.Text = txt.Text & vbCrLf & f End If Next f Else ''[キャンセル]ボタンがクリックされた 'MsgBox "キャンセルされました" End If End With Exit Sub ErrHandler: MsgBox Err.Description, vbExclamation End Sub |
標準モジュール
- テスト送信ボタン名はTESTとしてます。TEST_Click() ではメール送信者宛にテストメールを送ります。メール本文のレイアウト等をチェックするために利用できます。
- 一括配信ボタン名はAllSendとしてます。
- BASP21は、Declare～で利用できるようにしてます。
- bccで自分宛にもメール配信するようにしてます。
- メール配信結果は上段のListboxにOKかNGを出力します。
|
1 |
Option Explicit Declare PtrSafe Function SendMail Lib "Bsmtp.dll" _ (szServer As String, szTo As String, szFrom As String, _ szSubject As String, szBody As String, szFile As String) As String Declare PtrSafe Function FlushMail Lib "Bsmtp.dll" _ (szServer As String, szDir As String, szLogfile As String) As Long Sub TEST_Click() Dim ret As String Dim mailTo As String Dim buf(10) As String mailTo = Cells(5, 2).Value & vbTab & "bcc" & vbTab & Cells(5, 2).Value buf(0) = "テスト株式会社" ' 会社名 buf(1) = "営業部" ' 部署名 ret = MailSend(mailTo, "テスト送信先", buf) ' 送信チェック If ret <> "" Then MsgBox "送信できませんでした。" & vbCrLf & ret, vbOKOnly + vbCritical, "エラー" Else MsgBox "送信に成功しました。", vbOKOnly + vbInformation, "完了" End If End Sub Sub AllSend_Click() Dim ret As String Dim mailTo As String Dim usrName As String Dim sendCnt As Long Dim loopCnt As Long Dim i As Long Dim buf(10) As String loopCnt = Cells(10, 2).Value sendCnt = Cells(11, 2).Value If sendCnt = 0 Then MsgBox "送信可能件数が０のため処理を中止しました。" & vbCrLf & ret, vbOKOnly + vbCritical, "エラー" Exit Sub End If Sheets("メール送信").ListBox1.Clear For i = 1 To loopCnt mailTo = Sheets("一覧").Cells(i + 3, 10).Value & vbTab & "bcc" & vbTab & Cells(5, 2).Value usrName = Sheets("一覧").Cells(i + 3, 3).Value buf(0) = Sheets("一覧").Cells(i + 3, 1).Value ' 会社名 buf(1) = Sheets("一覧").Cells(i + 3, 2).Value ' 部署名 If Sheets("一覧").Cells(i + 3, 10).Value <> "" Then ret = MailSend(mailTo, usrName, buf) ' 送信後１秒待つ Application.Wait Now() + TimeValue("0:00:01") ' 送信チェック If ret <> "" Then Sheets("メール送信").ListBox1.AddItem "NG" & vbTab & usrName & vbTab & ret 'MsgBox "送信できませんでした。" & vbCrLf & ret, vbOKOnly + vbCritical, "エラー" Else Sheets("メール送信").ListBox1.AddItem "OK" & vbTab & usrName 'MsgBox "送信に成功しました。", vbOKOnly + vbInformation, "完了" End If Else Sheets("メール送信").ListBox1.AddItem "NG" & vbTab & usrName & vbTab & "メールアドレス未設定" End If Next End Sub Function MailSend(mailTo As String, usrName As String, info() As String) Dim ret As String Dim szServer As String, szTo As String, szFrom As String Dim szSubject As String, szBody As String, szFile As String Dim authId As String, authPass As String Dim toroku As String Dim bobj As Object Dim wshShell As Object Dim selectCol As Integer Dim buf As String, fileBuf As String ret = "" szServer = Cells(3, 2).Value & vbTab & Cells(4, 2).Value szFrom = Cells(6, 2).Value & "<" & Cells(5, 2).Value & ">" authId = Cells(7, 2).Value authPass = Cells(8, 2).Value If authId <> "" Then szFrom = szFrom & vbTab & authId & ":" & authPass End If ' 送信内容 If Cells(13, 2).Value = "1" Then selectCol = 4 fileBuf = Sheets("メール送信").txtFile1.Text ElseIf Cells(13, 2).Value = "2" Then selectCol = 6 fileBuf = Sheets("メール送信").txtFile2.Text ElseIf Cells(13, 2).Value = "3" Then selectCol = 8 fileBuf = Sheets("メール送信").txtFile3.Text ElseIf Cells(13, 2).Value = "4" Then selectCol = 10 fileBuf = Sheets("メール送信").txtFile4.Text ElseIf Cells(13, 2).Value = "5" Then selectCol = 12 fileBuf = Sheets("メール送信").txtFile5.Text End If ' 件名 szSubject = Cells(11, selectCol).Value ' 本文 buf = Cells(14, selectCol).Value buf = Replace(buf, "<name>", usrName) buf = Replace(buf, "<company>", info(0)) buf = Replace(buf, "<dept>", info(1)) szBody = buf & vbCrLf & vbCrLf _ & Cells(17, selectCol).Value ' 添付ファイル If Len(fileBuf) = 0 Then szFile = "" Else szFile = Replace(fileBuf, vbCrLf, vbTab) End If 'Set bobj = CreateObject("basp21") ret = SendMail(szServer, mailTo, szFrom, szSubject, szBody, szFile) 'ret = bobj.SendMail(szServer, mailTo, szFrom, szSubject, szBody, szFile) 'Set bobj = Nothing MailSend = ret End Function |
最後に
ファイルをダウンロード出来るようにしたので実際の動きを確認していただくのが良いと思います。
それからメールアドレスやメールの内容を間違って一括配信しても、私の責任ではありませんので内容を良く確認してから配信するように気を付けてください。