サイトアイコン あきらちんの技術メモ

EXCEL VBAでメール一括配信!添付ファイルも付けられるよ

ニーズの高いメールの一括配信処理ですが、お手軽にできる方法がなんだかパッとしません。※私が見つけられていないだけかもですが。。。

いろいろ検索してもVBAからメールソフトを利用する方法だったり、やり方が詳しく書かれていなかったりで、結局メールソフトで1件1件送っていたりします。

「先日も一覧表でメールアドレスのわかる方には一括でメールを送りたい!添付ファイルも付けたい!」と相談されておりました。

今までその方はWindowsソフトの”メールディストリビューター?”なるものを駆使して配信されておりましたが、配信先が変わるたび操作に手間取っていたので何とかしたいと思いややしばらくの間考えておりました。

ある日、ふと思い出しました。あ! BASP21 使えるかも!

随分昔に何かでつかっており、久々に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 を解凍して、現れた2つのファイル(Bsendm.exeとBsmtp.dll)を C:\Windows\System32 へ上書きコピーします。

メール配信用EXCELの準備

基本的に自由なレイアウトで作成していただいて良いと思います。私はこんな感じにしました。

作るのめんどくさい方はこちらからダウンロードしてください。

ご利用の際には、左上のメール設定を行ってから、校閲>シートの保護でパスワード設定してください。件名・本文・署名はシート保護後も編集可能です。

VBAの説明

メール送信シート
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
標準モジュール
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 "送信可能件数が0のため処理を中止しました。" & 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)             ' 送信後1秒待つ             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

最後に

ファイルをダウンロード出来るようにしたので実際の動きを確認していただくのが良いと思います。

それからメールアドレスやメールの内容を間違って一括配信しても、私の責任ではありませんので内容を良く確認してから配信するように気を付けてください。

モバイルバージョンを終了