こんにちは、もりです！
前回の記事では、Excelのデータを元に下書きメールを一括作成するマクロを紹介しました。
今回の記事では、下書きメールに「ファイルを添付する方法」を紹介します。
「複数ファイルを添付した下書きメールアイテム」を作成します。
作成した下書きは、下記のいずれかの処理ができます。
- 画面に表示させる
- 画面に表示はさせず、直接「下書き」フォルダに保存する
- 画面に表示はさせず、直接「送信」する
Contents
下書きメールを一括作成してファイル添付する
下書きアイテムの作成方法は、前回記事（【VBAでOutlook操作】Excelシートのデータから下書きメールを一括作成する）で紹介したとおりです。
【事前準備】Excelシートに「添付ファイルのキーワード」の列を追加する
前回記事のフォーマットに「添付ファイルキーワード」の列を追加します。※ご自身の業務要件に応じてフォーマットは調整してください。
- F列：添付ファイルのキーワードを追加
・佐藤さん宛てのメールには、ファイル名に”佐藤”が含まれるファイルを添付する
・鈴木さん宛てのメールには、ファイル名に”鈴木”が含まれるファイルを添付する
：
：
という仕組みです。
【事前準備】任意のフォルダにファイルを用意する
下書きメールに添付するファイルを、任意のフォルダに格納しておきます。
ここでは、C:\Outlookテスト\fileというパスの配下にファイルを格納しています。このパスをマクロのコード内に記述します。
ソースコード
下記を標準モジュールに貼り付けます。
- 参照設定で「Microsoft Outlook XX.0 Object Library」を使用
- 92行目の変数fileStorePathに、添付ファイルを格納しているパスを記述
- 事前にOutlookを起動しておき、mainプロシージャを実行
|
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 |
Enum col '列番号を定義 宛先 = 1 複写 = 2 氏名 = 3 使用日 = 4 金額 = 5 キーワード = 6 メール = 10 End Enum Sub main() Dim ws As Worksheet Set ws = ThisWorkbook.Sheets("mail") 'Outlookオブジェクトの作成 Dim OutlookObj As Outlook.Application Set OutlookObj = New Outlook.Application Dim r As Long, lastRow As Long lastRow = ws.Cells(1, 1).End(xlDown).Row For r = 2 To lastRow 'メールアイテムオブジェクト作成 Dim mailItemObj As Outlook.MailItem Set mailItemObj = OutlookObj.CreateItem(olMailItem) '添付ファイルオブジェクト作成 Dim attachObj As Outlook.Attachments Set attachObj = mailItemObj.Attachments 'メール本文の文字列を作成 Dim mailBody As String mailBody = CreateMailBody(ws, r) 'メールアイテム作成 With mailItemObj 'Outlookに複数アカウントを設定している場合、送信元アカウントを指定できる .SendUsingAccount = Session.Accounts("送信元メールアドレス") '省略可 .To = Cells(r, col.宛先).Value .CC = Cells(r, col.複写).Value .Subject = Cells(1, col.メール).Value '件名 .body = mailBody '本文 End With 'メールアイテムにファイルを添付する Dim keyword As String keyword = Cells(r, col.キーワード) Call FileAttach(attachObj, keyword) '下書きメールアイテムを表示 mailItemObj.Display '次のメールアイテムを作成するためいったん破棄 Set mailItemObj = Nothing Next r End Sub ' 【機能】Excelシート上の指定行番号のメール本文を作成する Function CreateMailBody(ws As Worksheet, r As Long) As String '氏名・使用日・金額 Dim sName As String, DayOfUse As String, price As Long sName = ws.Cells(r, col.氏名).Value DayOfUse = ws.Cells(r, col.使用日).Value price = ws.Cells(r, col.金額).Value Dim sign As String '署名 sign = ws.Cells(12, col.メール).Value Dim body As String 'メール本文 body = ws.Cells(2, col.メール).Value '初期値を設定 body = Replace(body, "（氏名）", sName) body = Replace(body, "（使用日）", DayOfUse) body = Replace(body, "（金額）", price) body = body & vbCrLf & vbCrLf & sign '末尾に署名を付与 CreateMailBody = body End Function ' 【機能】下書きメールアイテムにファイルを添付する ' 複数ファイル添付可能（キーワードを含むファイルをすべて添付する） ' キーワードを含むファイルが見つからない場合、何も添付しない Sub FileAttach(attachObj As Object, keyword As String) Dim fileStorePath As String 'ファイル格納パス fileStorePath = "C:\Outlookテスト\file" Dim fileName As String fileName = Dir(fileStorePath & "\" & "*") 'フォルダ内のファイル数、検索を繰り返す Do While fileName <> "" 'キーワードを含むファイルが見つかったら、下書きアイテムに添付する If InStr(fileName, keyword) > 0 Then attachObj.Add fileStorePath & "\" & fileName End If fileName = Dir() Loop Set attachObj = Nothing End Sub |
指定のパス配下のファイルを１つずつ検索し、指定のキーワード（”佐藤”や”鈴木”など）を含むファイルが見つかった場合、そのファイルを下書きメールに添付します。
キーワードを含むすべてのファイルを添付するため、指定フォルダ内のファイルを全件検索します。
キーワードを含むファイルが見つからない場合は、何も添付せず、メール本文のみを作成します。
【参考1】送信処理まで自動で行う
上記で紹介したコードは「下書きアイテムの作成」ですが、「送信処理」もマクロで実行することができます。
※事前に必ずテストして、誤送信のないよう、自己責任で慎重にお使いください！
54行目のメソッドを書き換えます。
mailItemObj.Display → mailItemObj.Send
送信したメールは、Outlookの「送信済みアイテム」に入ります。
【参考2】「下書き」フォルダに直接保存する
下書きメールアイテムを表示させず、直接「下書き」フォルダに保存することもできます。
54行目のメソッドを書き換えます。
mailItemObj.Display → mailItemObj.Save
メールの下書き作成からファイルの添付まで、めんどうくさいことは全部自動化しちゃいましょう！
添付ファイルが存在しない場合の処理
どうすればいーい？
連載目次：VBAでOutlook操作
Excelシートのデータから下書きメールを一括作成する方法、指定のキーワードに合致するファイルを添付する方法などを紹介しています。
