目次
有料になった「める配くん」
当サイト「サンクプランズ・コンサルティング」では各種ツールや資料を無料ダウンロードで提供しています。無料ではありますが、その代わりにメールアドレスを頂戴しまして、こちらからの情報提供に合意頂いた方へ不定期でメール配信させていただいております。
これはいわゆるメールマーケティングで、それほど積極的に行っているわけではありませんが、将来何らかのご縁があれば良いかなという感じで忘れたころに送っております。
毎日メルマガを送っておられる方もいますが、私の場合とてもそういう元気はないので、ごくたまに「これはお知らせすれば有益かも」というネタをお送りしています。
それで、その時に使っていたメール配信システムが「める配くん」で、無料版を長く愛用していたのですが、とうとう無料版が終了してしまいました（2週間の無料トライアルはある）。
考えてみれば無料のほうがおかしく、当然の有料化なのですが、それほどがっつりメルマガ運営している訳でもないので、課金するのもちょっともったいないな、ということになりました。
メール配信ツールを自作
他の無料ツールも調べたのですが、なかなか都合の良いものはなく「じゃあ自分で作ろう」ということになりました。
ベースとなるのはExcel VBAで、Excel VBAから同じマイクロソフトのOutlookを操作できるので、ExcelからOutlook経由でメール配信すれば良いじゃない、ということになりました。
基本的な流れ
今回準備したメール配信システムは以下の流れで使います。
（１）あらかじめ送信元として使いたいアドレスをOutlookのほうにアカウント追加しておき、そのアカウントを送信元（From）として使う
（２）「メールアドレス」というタブのA列に送り先のメールアドレスをずらっと並べる
（３）「本文」というタブを用意して
A2セルに送付するメールの件名（Subject）を書く
B2セルに送りたいメールの本文を書く（エディタで書いてコピーする）
C2セルにメール文末の署名（会社名や名前など）を書く
（４）以下のExcel VBAコードを走らせる
以上でFromのアドレスからメールアドレスあてに同じ本文のメールを1件1件送信します。
今のところ特に問題なく運用しています。
VBAコード
以下のとおりですので、コピペしてお試し頂ければ幸いです。
Sub send_mail()
Dim rowsData1 As Long '行数カウント用の変数
Dim i As Integer
'予約履歴DBの行数を数える
rowsData1 = ThisWorkbook.Worksheets("メールアドレス").Cells(Rows.Count, 1).End(xlUp).Row '最後の行数を取得
For i = 1 To rowsData1
'Outlookアプリケーションを起動
Dim outlookObj As Outlook.Application
Set outlookObj = CreateObject("Outlook.Application")
'Outlookメールを作成
Dim mymail As Outlook.MailItem
Set mymail = outlookObj.CreateItem(olMailItem)
'Outlookに登録されているアカウント名を指定
Dim oAccount As Outlook.Account
Set oAccount = outlookObj.Session.Accounts.Item("税理士法人船津会計")
'メール本文を設定
Dim mailbody As String, credit As String
'メール情報を設定
mymail.BodyFormat = 3 'リッチテキストに変更
mymail.SendUsingAccount = oAccount '送信元を設定
'送信元として相手に表示される名称を設定
mymail.SentOnBehalfOfName = "税理士法人船津会計 <xxx@xxxxx.com>"
'To宛先
mymail.TO = ThisWorkbook.Worksheets("メールアドレス").Cells(i, 1).Value
'件名
mymail.Subject = ThisWorkbook.Worksheets("本文").Cells(1, 2).Value
mailbody = ThisWorkbook.Worksheets("本文").Cells(2, 2).Value
credit = ThisWorkbook.Worksheets("本文").Cells(3, 2).Value
mymail.Body = mailbody & vbCrLf & vbCrLf & credit
'メール保存
mymail.Save
'メール送信
mymail.Send
'オブジェクト解放
Set outlookObj = Nothing
Set mymail = Nothing
Next
End Sub