Outlookの差し込みメールを作成するExcelVBA(メール作成④)

スポンサーリンク

Outlookのメール作成ツールはかなり用途が広い

以前にOutlookで差し込み印刷のようにメール本文を作成するExcelVBA(メール作成③)で差し込み印刷のように複数のメールを作成するExcelVBAをご紹介しましたが、職場で同僚に使ってもらっていたところ修正案が出てきましたので更新してご紹介します。

Outlookの差し込みメール作成ツールについて

このメール作成ツールはたくさんの宛先に内容をほんの少しだけ変えたメールを送る必要がある場合に使うツールです。

変更部分を<項目名>とした本文を作成し、表に差し込みたい内容を表に記載することで複数のメールを一括で作成できます。詳しい操作手順に関してはこちらの記事をご確認ください。

スポンサーリンク

Outlookのメール作成VBAの変更点は大きく5点

今回追加した機能としては下記5点になります。

①件名についても差し込みを実行する

前回の紹介したVBAコードでは本文のみを対象として差し込みを行っていましたが、件名についても差し込みできるように修正しました。

②宛先・CCを複数登録可能

前回の記事では宛先・CCは1つだけを想定して作成していましたが、複数の宛先でも記載できるように修正しました。

③添付ファイルの複数登録

前回の記事はセル1つに1つの添付ファイルを記載し、2列で合計2つのファイルを添付できる作りにしていましたが、複数の添付を想定し、1つのセルに記載することで完結できるように修正しました。

④送信しないフラグの設定

リストをそのまま貼り付けて、そのうち一部は送信しなくても良いなどの場合、リストから行を削除するのではなく、送信しなくて済ませられるようにフラグを設定しました。

⑤差し込み項目数を増やす

前回は差し込み内容が2つで作成しましたが、もっとたくさん使用できる方が都合が良いとのことで、項目数を15としました。

サンプルコード使用時の注意点

今回ご紹介するExcelVBAコードは参照設定が必要です。

Outlookに関するライブラリーを参照するので「Microsoft Outlook ×× Object Library」(××はバージョンによって変わります。)を有効にしてください。手順が不明な場合はこちらを確認してください。

Outlook差し込みメール作成ツール

①差し込みメール作成用Excelシート

差し込みメール作成に使用するExcelのシートは下記のように準備しています。

112-001

本文中の<>で囲まれた部分が6行目E列からS列までの項目名と一致する部分について表の中の情報に置き換える仕様です。
例えば件名に記載している<件名ヘッダー>は今回作成する2つのメールではそれぞれE列の7行目「該当者連絡」、8行目「業務連絡」という文言に置き換えられます。

また、左上にはメール作成の起動ボタンを用意していて、クリックすることでOutlookが起動するように設定しています。

②差し込みメール作成のVBAコード

今回作成したVBAコードは以下のようになります。

Sub Outlook起動してメール作成する()

Dim oApp As New Outlook.Application
Dim oItem As Outlook.MailItem

Dim WSH As Object
Set WSH = CreateObject(“Wscript.Shell”)
Dim DesktopPath As String
DesktopPath = WSH.SpecialFolders(“Desktop”)

Dim 本文 As String, 件名 As String
Dim 宛先列番号 As Long
Dim i, k, x

i = 7
Do Until Cells(i, 2) = “”
If Cells(i, 21) = “” Then
件名 = Cells(2, 2).Text
本文 = Cells(3, 2).Text
k = 5
Do Until Cells(6, k) = “”
件名 = Replace(件名, “<” & Cells(6, k) & “>”, Cells(i, k))
本文 = Replace(本文, “<” & Cells(6, k) & “>”, Cells(i, k))
k = k + 1
Loop
本文 = Replace(本文, vbLf, “<br />”)

Set oItem = oApp.CreateItem(olMailItem)

’oItem.SendUsingAccount = Session.Accounts(“touhangaibukenshu@matsukiyo.co.jp”)

oItem.To = Replace(Cells(i, 2), vbLf, “;”)
oItem.Subject = 件名
oItem.HTMLBody = “” & 本文 & “

oItem.CC = Replace(Cells(i, 3), vbLf, “;”)
oItem.BCC = Replace(Cells(i, 4), vbLf, “;”)
’oItem.Importance = olImportanceHigh

Dim 添付()
x = 0
ReDim Preserve 添付(x)
添付(x) = Cells(i, 20).Text

If 添付(x) <> “” Then
Select Case InStr(添付(x), vbLf)
Case Is = 0
oItem.Attachments.Add DesktopPath & “\” & 添付(x)
Case Else
Do Until InStr(添付(x), vbLf) = 0
x = x + 1
ReDim Preserve 添付(x)
添付(x) = Mid(添付(x - 1), InStr(添付(x - 1), vbLf) + 1)
添付(x - 1) = Left(添付(x - 1), InStr(添付(x - 1), vbLf) - 1)
If 添付(x - 1) <> “” Then
oItem.Attachments.Add DesktopPath & “\” & 添付(x - 1)
End If
Loop
If 添付(x) <> “” Then
oItem.Attachments.Add DesktopPath & “\” & 添付(x)
End If
End Select

End If

oItem.Display ’送信せずに画面を表示する
’oItem.Save ’下書き保存
’oItem.Close 0 ’閉じる
’oItem.Send ’送る場合

End If

i = i + 1
Loop

End Sub
スポンサーリンク

シェアする

  • このエントリーをはてなブックマークに追加

フォローする