メールの一斉送信ツールをマクロで作ってみたので紹介します。（ファイルをダウンロードし設定を変更するだけで使えます！）
このツールでは以下の機能が利用できます。
（１）送信先毎に本文の宛名を変更可能
（２）CC、BCCが複数指定可能
（３）添付ファイル３つまで可能
では利用手順を紹介していきます。ちなみにこちらのツールですが「髙﨑…etc」といった外字を含む文章を送付した際に、文字化けしてしまうメーラーがいくつかあるので注意してください。 ※すべて自己責任でお願いします。
BASP21のインストール
こちらからファイルをダウンロードし展開してください。展開フォルダ内の「BASP21-2003-0211.exe」を実行します。実行が完了したら、下記フォルダへ「Bsendm.exe」と「Bsmtp.dll」をコピーします。
・64bitならC:\Windows\SysWOW64
・32bitならC:\Windows\System32
マクロの編集
こちらからファイルをダウンロードしてください。ファイルを開き「Alt + F11」を押してエディターを立ち上げてください。「標準モジュール」を開き以下のソースコードにて【】で囲まれた箇所を環境に合わせて編集してください。
|
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 |
[vb] Sub cmd送信() If vbYes = MsgBox("実行しますか？", vbYesNo) Then Else MsgBox "処理を中止しました。" Exit Sub End If 'エラーが発生したら処理を行なう On Error GoTo Err_Shori '変数定義 Dim bobj As Object Dim svname As String Dim id As String Dim tmp As String Dim pass As String Dim msg As Variant Dim files As String Dim objFso As Object Set objFso = CreateObject("Scripting.FileSystemObject") 'SMTPサーバ名:ポート番号:タイムアウト秒 svname = "【サーバー名称】:【SMTPポート番号】:60" 'ログインID id = "【メールアドレス】" 'パスワード pass = "【メールパスワード】" 'オブジェクトを作成 Set bobj = CreateObject("basp21") '件名 subj = Sheets("送信").Range("E2").Value '添付パス tmppath = "【ファイルの場所】\" '添付ファイル① tmp = tmppath & Sheets("送信").Range("H2").Value '添付ファイル② If Sheets("送信").Range("I2") <> "" Then tmp = tmp & vbTab & tmppath & Sheets("送信").Range("I2").Value End If '添付ファイル③ If Sheets("送信").Range("J2") <> "" Then tmp = tmp & vbTab & tmppath & Sheets("送信").Range("J2").Value End If files = Trim(tmp) '送信者 mailfrom = "【会社名】<" & id & ">" & vbTab & id & ":" & pass Dim MaxRow: MaxRow = Range("A1").End(xlDown).Row For i = 2 To MaxRow '宛先 mailto = Replace(Sheets("送信").Cells(i, 1).Value, ",", vbTab) 'CC If Sheets("送信").Range("F2") <> "" Then mailto = mailto & vbTab & "cc" & vbTab & Replace(Sheets("送信").Range("F2").Value, ",", vbTab) End If 'BCC If Sheets("送信").Range("G2").Value <> "" Then mailto = mailto & vbTab & "bcc" & vbTab & Replace(Sheets("送信").Range("G2").Value, ",", vbTab) End If '本文 改行はvbCrLf body = Replace(Sheets("本文").Cells(1, 1).Value, "〇〇〇〇", Sheets("送信").Cells(i, 2).Value) body = Replace(body, "△△△△", Sheets("送信").Cells(i, 3).Value) 'メール送信 msg = bobj.SendMail(svname, mailto, mailfrom, subj, body, files) ' 送付エラーの処理 If msg <> "" Then 'ログ書き込み With objFso.OpenTextFile("【ログファイルの場所と名前】", 8) .WriteLine Now & vbTab & Sheets("送信").Cells(i, 2).Value & "様への送付でエラーが発生しました。" .Close End With MsgBox "送信できませんでした。" & vbCrLf & msg, vbOKOnly + vbCritical, "送信時エラー" '送付正常終了の処理 Else 'ログ書き込み With objFso.OpenTextFile("【ログファイルの場所と名前】", 8) .WriteLine Now & vbTab & Sheets("送信").Cells(i, 2).Value & "様への送付が完了しました。" .Close End With End If Next i MsgBox "送信に成功しました。", vbOKOnly + vbInformation, "完了" Err_Shori_Exit: Set objFso = Nothing Exit Sub 'ここからエラー処理 Err_Shori: MsgBox Err.Description, vbOKOnly + vbCritical, "実行時エラー" Resume Err_Shori_Exit 'ここまで End Sub [/vb] |
シートの確認
シートの入力について補足を入れてありますが、こちらでも記載しておきます。
① 送信シート
【宛先】：送付先メールアドレスを入力してください。１通のメールに複数の送付先を適用させたい場合は、アドレスをカンマ区切りで入力してください。
【会社名】：本文の宛名に表示される会社名を入力してください。相手方が個人の場合は未入力で大丈夫です。
【担当者名】：本文の宛名に表示される担当者名を入力してください。
【件名】：件名を入力してください。
【CC】：CCを入力してください。複数ある場合はカンマ区切りで入力してください。
【BCC】：BCCを入力してください。複数ある場合はカンマ区切りで入力してください。
【添付ファイル①～③】：添付ファイル名（拡張子含む）を入力してください。最大３つまで添付できます。※①から順に入力してください。
【メール送信ボタン】：処理を実行するボタンです。メールが送信されます。
② 本文シート
【本文】：メール本文を入力してください。〇〇〇〇が送信シートで入力した「会社名」、△△△△が「担当者名」に置換されます。※相手方が個人の場合は〇〇〇〇を削除してください。
まとめ
設定については、プログラムをインストールしファイルを少し編集するだけなので比較的楽に進められると思います。是非、試してみてください！