VBAでOutlook操作・下書きメールにファイルを添付する方法を紹介しています！
前回の記事では、「キーワードに一致するファイルが存在しない場合、下書きメールを作成しないマクロ」を紹介しました。
【VBAでOutlook操作】添付ファイルの有無を判定して下書きメールを作成するVBAでOutlook操作をしよう！下書きメールの作成・ファイルの添付方法を紹介しています。「キーワードに一致したファイルが存在しない場合はメールを作成しない」という処理を加えています。...
ねぇ、もりさん。これまで作ってきたマクロって、添付するファイルのキーワードを1つしか指定できないよね。
複数キーワードを指定できないかな？
もり
なるほどね～。作ってみよう！
Excelシートのデータを元に、Outlookの下書きアイテムを一括作成するマクロを紹介します。
- 下書きメールを作成する
- 指定のキーワードに一致するファイルを添付する（複数ファイル添付可能）
（※キーワードに一致するファイルが見つからない場合、下書きメールを作成しない） - 添付ファイルのキーワードに、複数単語を指定できるようにする（←今回のポイント）
スポンサーリンク
キーワードをカンマ区切りで指定する
もり
Excelシート上で、カンマ区切りでキーワードを指定するだけでOK
キーワードが1つのみの場合は、カンマ不要です。
FileAttachプロシージャの変更
前回までに作成したコードの、FileAttachプロシージャのみを変更します。
- 引数で受け取ったkeywordを、Split関数でカンマ区切りにして配列に格納する
- 配列の要素数（キーワードの数）、処理を繰り返す
|
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 |
Function FileAttach(attachObj As Object, keyword As String) As Boolean Dim fileCnt As Long '添付したファイル数をカウントする Dim FileStorePath As String 'ファイル格納パス FileStorePath = "C:\Outlookテスト\file" Dim arrKeyword As Variant arrKeyword = Split(keyword, ",") 'キーワードをカンマ区切りする Dim n As Long 'キーワードの数、処理を繰り返す For n = LBound(arrKeyword) To UBound(arrKeyword) Dim FileName As String FileName = Dir(FileStorePath & "\" & "*") 'フォルダ内のファイル数、検索を繰り返す&" Do While FileName <> "" 'キーワードを含むファイルが見つかったら、下書きアイテムに添付する If InStr(FileName, arrKeyword(n)) > 0 Then attachObj.Add FileStorePath & "\" & FileName fileCnt = fileCnt + 1 '添付したファイル数 End If FileName = Dir() Loop Next n Set attachObj = Nothing '1以上のファイルを添付した場合Trueを返す '（Boolean型の初期値はFalse） If fileCnt > 0 Then FileAttach = True End Function |
コードまとめ
シリーズを通して作成したコードのまとめです。このコードを動作させるためには、以下の2点が必要です。
- 参照設定「Microsoft Outlook xx.0 Object Library」
- Outlookを起動しておく
|
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 115 116 117 |
Option Explicit Enum col '1以降の数値を省略した場合は+1される 宛先 = 1 複写 氏名 使用日 金額 添付キーワード End Enum Sub main() 'Outlookオブジェクトの作成 Dim OutlookObj As Outlook.Application Set OutlookObj = New Outlook.Application Dim r As Long For r = 2 To Cells(1, 1).End(xlDown).Row 'メールアイテムオブジェクト作成 Dim mailItemObj As Outlook.MailItem Set mailItemObj = OutlookObj.CreateItem(olMailItem) '添付ファイルオブジェクトの生成 Dim attachObj As Outlook.Attachments Set attachObj = mailItemObj.Attachments Dim keyword As String keyword = Cells(r, col.添付キーワード) '添付ファイルが存在する場合のみ、メールアイテムを作成する If FileAttach(attachObj, keyword) = True Then 'メール本文作成 Dim mailBody As String mailBody = CreateMailBody(r) 'メールアイテム作成 With mailItemObj .To = Cells(r, col.宛先).Value .CC = Cells(r, col.複写).Value .Subject = Cells(1, "J").Value '件名 .Body = mailBody '本文 End With mailItemObj.Display '下書きを表示 '次のメールアイテムを作成するためいったん破棄 Set mailItemObj = Nothing End If Next r End Sub ' 【機能】Excelシート上の指定行番号のメール本文を作成する Function CreateMailBody(r As Long) As String Dim sName As String, DayOfUse As String, price As Long sName = Cells(r, col.氏名).Value DayOfUse = Cells(r, col.使用日).Value price = Cells(r, col.金額).Value Dim sign As String '署名 sign = Cells(12, "J").Value Dim mBody As String 'メール本文 mBody = Cells(2, "J").Value '初期値を設定 mBody = Replace(mBody, "（氏名）", sName) mBody = Replace(mBody, "（使用日）", DayOfUse) mBody = Replace(mBody, "（金額）", price) mBody = mBody & vbCrLf & vbCrLf & sign '末尾に署名を付与 CreateMailBody = mBody End Function Function FileAttach(attachObj As Object, keyword As String) As Boolean Dim fileCnt As Long '添付したファイル数をカウントする Dim FileStorePath As String 'ファイル格納パス FileStorePath = "C:\Outlookテスト\file" Dim arrKeyword As Variant arrKeyword = Split(keyword, ",") 'キーワードをカンマ区切りする Dim n As Long 'キーワードの数、処理を繰り返す For n = LBound(arrKeyword) To UBound(arrKeyword) Dim FileName As String FileName = Dir(FileStorePath & "\" & "*") 'フォルダ内のファイル数、検索を繰り返す&" Do While FileName <> "" 'キーワードを含むファイルが見つかったら、下書きアイテムに添付する If InStr(FileName, arrKeyword(n)) > 0 Then attachObj.Add FileStorePath & "\" & FileName fileCnt = fileCnt + 1 '添付したファイル数 End If FileName = Dir() Loop Next n Set attachObj = Nothing '1以上のファイルを添付した場合Trueを返す '（Boolean型の初期値はFalse） If fileCnt > 0 Then FileAttach = True End Function |
連載目次：VBAでOutlook操作
Excelシートのデータから下書きメールを一括作成する方法、指定のキーワードに合致するファイルを添付する方法などを紹介しています。
スポンサーリンク
スポンサーリンク
