質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

新規登録して質問してみよう
ただいま回答率
85.50%
VBA

VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

マクロ

定義された処理手続きに応じて、どのような一連の処理を行うのかを特定させるルールをマクロと呼びます。

Q&A

解決済

2回答

6454閲覧

VBAで、複数ファイルを添付したメールを一括作成したい。

oftn

総合スコア19

VBA

VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

マクロ

定義された処理手続きに応じて、どのような一連の処理を行うのかを特定させるルールをマクロと呼びます。

0グッド

0クリップ

投稿2020/05/04 10:07

編集2020/05/06 08:49

標記の通りなのですが、VBAで、複数ファイルを添付したメールを一括作成したいです。
メールはOutlookです。
複数ファイルというのは、一つのフォルダ上に格納されているファイルではなく、
ある規則性によって作成されているフォルダ内に、格納されているファイルのことを指します。
添付画像のようなファルダ構造になっており、
「通知」フォルダを添付させる用のメールのVBAを起動させると、
各先生配下の、さらにクラス名配下の、「通知」のフォルダ内のファイルが、
各先生に送信されるようにしたいです。

イメージ説明

ある特定のフォルダから、エクセル上の「添付キーワード」と一致するファイル名のファイルを各先生あてに送信はできるようにはなったのですが、
上記の太字のような、フォルダ構成を考慮して添付ファイルをつけることができません。
③FileAttachの以下の部分
Dim FileStorePath As String 'ファイル格納パス
FileStorePath = "C:\Outlookテスト\aaa先生\1-1\通知"
を編集して、パス名にも、先生名やクラス名をループで入るようにすればいいのでは、
と思うのですが、うまくいかないため、
各先生配下のいづれのクラスにおいて共通のフォルダ名内のファイルを添付したメールを、クラスごとに作成する方法について、
お力を貸してください。

下に添付のようなエクセルで、宛先などを定義しています。
イメージ説明

①main

VBA

1Enum col '1以降の数値を省略した場合は+1される 2 宛先 = 1 3 複写 4 クラス名 5 氏名 6 添付キーワード 7End Enum 8 9Sub main() 10 11 'Outlookオブジェクトの作成 12 Dim OutlookObj As Outlook.Application 13 Set OutlookObj = New Outlook.Application 14 15 Dim r As Long 16 For r = 2 To Cells(1, 1).End(xlDown).Row 17 18 'メールアイテムオブジェクト作成 19 Dim mailItemObj As Outlook.MailItem 20 Set mailItemObj = OutlookObj.CreateItem(olMailItem) 21 22 '添付ファイルオブジェクトの生成 23 Dim attachObj As Outlook.Attachments 24 Set attachObj = mailItemObj.Attachments 25 26 Dim keyword As String 27 keyword = Cells(r, col.添付キーワード) 28 29 '★添付ファイルが存在する場合のみ、メールアイテムを作成する 30 If FileAttach(attachObj, keyword) = True Then 31 32 'メール本文作成 33 Dim mailBody As String 34 mailBody = CreateMailBody(r) 35 36 'メールアイテム作成 37 With mailItemObj 38 .To = Cells(r, col.宛先).Value 39 .CC = Cells(r, col.複写).Value 40 .Subject = Cells(1, "I").Value '件名 41 .Body = mailBody '本文 42 End With 43 44 mailItemObj.Display '下書きを表示 45 46 '次のメールアイテムを作成するためいったん破棄 47 Set mailItemObj = Nothing 48 49 End If 50 51 Next r 52 53End Sub 54

②CreateMailBody

VBA

1 2' 【機能】Excelシート上の指定行番号のメール本文を作成する 3Function CreateMailBody(r As Long) As String 4 5 Dim cName As String, sName As String 6 cName = Cells(r, col.クラス名).Value 7 sName = Cells(r, col.氏名).Value 8 9 ' Dim sign As String '署名 10 ' sign = Cells(12, "I").Value 11 12 Dim mBody As String 'メール本文 13 mBody = Cells(2, "I").Value '初期値を設定 14 mBody = Replace(mBody, "(クラス名)", cName) 15 mBody = Replace(mBody, "(氏名)", sName) 16 ' mBody = mBody & vbCrLf & vbCrLf & sign '末尾に署名を付与 17 18 CreateMailBody = mBody 19 20End Function 21

③FileAttach

VBA

1' 処理① キーワードに合致するファイルを添付する 2' 処理② 1つ以上のファイルが見つかった場合、Trueを返す 3Function FileAttach(attachObj As Object, keyword As String) As Boolean 4 5 Dim fileCnt As Long '★添付したファイル数をカウントする 6 7 Dim FileStorePath As String 'ファイル格納パス 8 FileStorePath = "C:\Outlookテスト\aaa先生\1-1\通知" 9 10 Dim FileName As String 11 FileName = Dir(FileStorePath & "\" & "*") 12 13 'フォルダ内のファイル数、検索を繰り返す&" 14 Do While FileName <> "" 15 16 'キーワードを含むファイルが見つかったら、下書きアイテムに添付する 17 If InStr(FileName, keyword) > 0 Then 18 attachObj.Add FileStorePath & "\" & FileName 19 fileCnt = fileCnt + 1 '★添付したファイル数 20 End If 21 22 FileName = Dir() 23 24 Loop 25 26 Set attachObj = Nothing 27 28 '★1以上のファイルを添付した場合Trueを返す 29 '(Boolean型の初期値はFalse) 30 If fileCnt > 0 Then FileAttach = True 31 32End Function 33

(2020/05/06 追記)
コメントいただいたように、VBAを編集してみたのですが、うまく実行しません…。
エクセルもすこし変更しました。
FileStorePathで指定したフォルダ内を「添付キーワード」で検索するのではなく、
FileStorePathで指定したフォルダ内のファイルをすべてメールに添付したいのですが、
さらにどこを修正したらよいでしょうか…。
イメージ説明
③FileAttach(変更版)

VBA

1' 処理① キーワードに合致するファイルを添付する 2' 処理② 1つ以上のファイルが見つかった場合、Trueを返す 3Function FileAttach(attachObj As Object, keyword As String) As Boolean 4 5 Dim fileCnt As Long '★添付したファイル数をカウントする 6 7 Dim FileStorePath As String 'ファイル格納パス 8 FileStorePath = "C:\Outlookテスト\" & Cells(r, "D") & "先生\" & Cells(r, "E") & "\通知" 9 10 Dim FileName As String 11 FileName = Dir(FileStorePath & "\" & "*") 12 13 'フォルダ内のファイル数、検索を繰り返す&" 14 Do While FileName <> "" 15 16 'キーワードを含むファイルが見つかったら、下書きアイテムに添付する 17 **'↑は無し。FileStorePathに格納されているファイルすべてを送信したい。** 18 'If Array(FileName) > 0 Then 19 ' attachObj.Add FileStorePath & "\" & FileName 20 ' fileCnt = fileCnt + 1 '★添付したファイル数 21 'End If 22 23 FileName = Dir() 24 25 Loop 26 27 Set attachObj = Nothing 28 29 '★1以上のファイルを添付した場合Trueを返す 30 '(Boolean型の初期値はFalse) 31 If fileCnt > 0 Then FileAttach = True 32 33End Function 34

気になる質問をクリップする

クリップした質問は、後からいつでもMYページで確認できます。

またクリップした質問に回答があった際、通知やメールを受け取ることができます。

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

guest

回答2

0

ベストアンサー

どこかにフォルダー種別のセル作るか、F列に並べるかして
main()で文字列作って、FileAttachにわたすとか。
例)F列に並べると

vba

1FileStorePath = "C:\Outlookテスト\" & Cells(r,"D"& "先生\" & Cells(r,"E") & "\" & cells(r,"F"

または専用だと、通知.xlsmには、

vba

1FileStorePath = "C:\Outlookテスト\" & Cells(r,"D"& "先生\" & Cells(r,"E") & "\通知"

とか

追記1
ほぼ完成かと、、keyword使わないので消したほうがいいですね

FileAttach

VBA

1' 処理① キーワードに合致するファイルを添付する 2' 処理② 1つ以上のファイルが見つかった場合、Trueを返す 3Function FileAttach(attachObj As Object) As Boolean 4 5 Dim fileCnt As Long '★添付したファイル数をカウントする 6 7 Dim FileStorePath As String 'ファイル格納パス 8 FileStorePath = "C:\Outlookテスト\" & Cells(r, "D") & "先生\" & Cells(r, "E") & "\通知" 9 10 Dim FileName As String 11 FileName = Dir(FileStorePath & "\" & "*") 12 13 'フォルダ内のファイル数、検索を繰り返す&" 14 Do While FileName <> "" 15 'Debug.Print FileStorePath & "\" & FileName 16 attachObj.Add FileStorePath & "\" & FileName 17 fileCnt = fileCnt + 1 '★添付したファイル数 18 FileName = Dir() 19 20 Loop 21 22 Set attachObj = Nothing 23 24 '★1以上のファイルを添付した場合Trueを返す 25 '(Boolean型の初期値はFalse) 26 If fileCnt > 0 Then FileAttach = True 27 28End Function

main修正前

VBA

1 Dim keyword As String 2 keyword = Cells(r, col.添付キーワード) 3 4 '★添付ファイルが存在する場合のみ、メールアイテムを作成する 5 If FileAttach(attachObj, keyword) = True Then 6

main修正後

VBA

1 2 '★添付ファイルが存在する場合のみ、メールアイテムを作成する 3 If FileAttach(attachObj) = True Then 4

追記2
イメージ説明
Dim Col As Colsを宣言することによて、クラス名と先生氏名がぶら下がり、Col.クラス名とCol.先生氏名が使えるようになります。ステップ実行やブレークポイントで止めてColをクイックウォッチに登録すると右のようにColの下にクラス名 As Longと先生氏名 As Longがあるのがわかると思います。

追記3
全体の流れ見ていませんでした、すみません。
main()でファイルパス作って、FileAttachに渡さないといけなかったです。

VBA

1Enum Col '1以降の数値を省略した場合は+1される 2 宛先 = 1 3 複写 4 クラス名 5 氏名 6 添付キーワード 7 先生氏名 8End Enum 9 10Sub main() 11 Dim Col As Cols 12 Dim r As Long 13 'Outlookオブジェクトの作成 14 Dim OutlookObj As Outlook.Application 15 Set OutlookObj = New Outlook.Application 16 17 Dim r As Long 18 For r = 2 To Cells(1, 1).End(xlDown).Row 19 20 'メールアイテムオブジェクト作成 21 Dim mailItemObj As Outlook.MailItem 22 Set mailItemObj = OutlookObj.CreateItem(olMailItem) 23 24 '添付ファイルオブジェクトの生成 25 Dim attachObj As Outlook.Attachments 26 Set attachObj = mailItemObj.Attachments 27 28 Dim cName As String, sName As String, tName As String 29 cName = Cells(r, Col.クラス名).Value 30 tName = Cells(r, Col.先生氏名).Value 31 32 FileStorePath = "C:\Outlookテスト\" & tName & "先生\" & cName & "\通知" 33 34 '★添付ファイルが存在する場合のみ、メールアイテムを作成する 35 If FileAttach(attachObj, FileStorePath) = True Then 36 37 'メール本文作成 38 Dim mailBody As String 39 mailBody = CreateMailBody(r) 40 41 'メールアイテム作成 42 With mailItemObj 43 .To = Cells(r, Col.宛先).Value 44 .CC = Cells(r, Col.複写).Value 45 .Subject = Cells(1, "I").Value '件名 46 .Body = mailBody '本文 47 End With 48 49 mailItemObj.Display '下書きを表示 50 51 '次のメールアイテムを作成するためいったん破棄 52 Set mailItemObj = Nothing 53 54 End If 55End Sub 56

VBA

1Function FileAttach(attachObj As Object, FileStorePath As String) As Boolean 2 3 Dim fileCnt As Long '★添付したファイル数をカウントする 4 5 Dim FileName As String 6 FileName = Dir(FileStorePath & "\" & "*") 7 8 'フォルダ内のファイル数、検索を繰り返す&" 9 Do While FileName <> "" 10 attachObj.Add FileStorePath & "\" & FileName 11 fileCnt = fileCnt + 1 '★添付したファイル数 12 FileName = Dir() 13 14 FileName = Dir() 15 Loop 16 17 Set attachObj = Nothing 18 19 '★1以上のファイルを添付した場合Trueを返す 20 '(Boolean型の初期値はFalse) 21 If fileCnt > 0 Then FileAttach = True 22 23End Function

投稿2020/05/04 13:33

編集2020/05/08 13:28
sinzou

総合スコア392

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

oftn

2020/05/06 08:53

いったん動くものを作りたいので、「通知」専用で作っていまして、 2つ目に書いていただいた FileStorePath = "C:\Outlookテスト\" & Cells(r,"D")& "先生\" & Cells(r,"E") & "\通知" を入れてみました。 かつ「添付キーワード」でFileStorePath内を検索するのではなく、FileStorePath内のファイルをすべて添付したいと思っているので、修正してみたのですが、動きません。 不勉強で申し訳ないのですが、どこを修正すればよいか、もしお時間ありましたら指摘いただけると幸いです。
oftn

2020/05/06 12:07

追記ありがとうございます。 FileStorePath = "C:\Outlookテスト\" & Cells(r,"D")& "先生\" & Cells(r,"E") & "\通知" の、Cells(r,"D")/ Cells(r,"E") の部分でエラーになってしまうので、先にtNameらの変数宣言をしてからFileAttach に変数を入れてみたのですが、それでも「アプリケーション定義またはオブジェクト定義のエラーです」と、tNameの宣言のところで出てしまいます。 CellsはFileAttach内ではここでしか使っていないと思うのですが、何か解決策をご存じでしょうか…。 何度も申し訳ありません…。 【FileAttach内】 Dim cName As String, sName As String, tName As String cName = Cells(r, col.クラス名).Value tName = Cells(r, col.先生氏名).Value FileStorePath = "C:\Outlookテスト\" & tName & "先生\" & cName & "\通知"
sinzou

2020/05/06 23:24 編集

下記テスト願います。 実行時シートの確認と行、列番号入れ替えて確認してください Type Cols クラス名 As Long 先生氏名 As Long End Type Sub tes() Dim Col As Cols Dim r As Long '設定 r = 3 '3行目 Col.クラス名 = 3 'C列 Col.先生氏名 = 6 'F列 'テスト Dim cName As String, sName As String, tName As String cName = Cells(r, Col.クラス名).Value tName = Cells(r, Col.先生氏名).Value FileStorePath = "C:\Outlookテスト\" & tName & "先生\" & cName & "\通知" MsgBox FileStorePath End Sub
sinzou

2020/05/06 23:27

列番号や英字でなく項目名から列を指定したいですか? Col.クラス名 = Range("1:1").Find("クラス名").Column Col.先生氏名 = Range("1:1").Find("先生氏名").Column
oftn

2020/05/07 14:38 編集

列番号で列を指定したいです。 列とシートを確認してtesを実行すると、「C:\Outlookテスト\aaa先生\1-2\通知」と表示されます。 mainを実行したところ、エラー1004はなくなったのですが、 ファイルが通知フォルダ配下にあるにも関わらず、 メールが一通も作成されません。 FileAttachでデバッグをしてみたところ、rがnullになってしまっており、cName、tNameの値が取れていないようです。
sinzou

2020/05/08 00:00

Cells(1, 1).End(xlDown).Row は、 A1セル選択後、Endキー押してから下矢印キー押したときのセル位置の行取得しています。 一度キー操作して何行目になるか確認願います。
oftn

2020/05/08 11:16

5行目になりました。 いったんcNameとtNameを別に宣言するのを、 FileStorePath内で定義するスクリプトに戻し、 デバッグで、Cells(r, Col.クラス名)上にカーソルを合わせると、 Cells(r, Col.クラス名)=<アプリケーション定義またはオブジェクト定義の定義のエラーです> r=Empty 値 の二つが表示されます。
sinzou

2020/05/08 13:07

追記2しました。
sinzou

2020/05/08 13:31 編集

追記3、全体の流れ見てませんでした。すみません 追記2無視してください。今回使わないです。
oftn

2020/05/08 15:25

丁寧にありがとうございます。 FileStorePathはmainで定義しないといけなかったんですね。 解決しました。 ありがとうございました。
guest

0

もっといい方法があるかもしれませんが、
③FileAttach内FileStorePathを再帰処理で求めます。

VBA

1FileStorePath = getTgtPath("C:\Outlookテスト", keyword) & "\通知"

VBA

1Function getTgtPath(FPath As String, keyword As String) 2' keywordを含むフォルダーパスを返す 3 Dim FSO As Object, Folder As Variant, File As Variant 4 Set FSO = CreateObject("Scripting.FileSystemObject") 5 For Each Folder In FSO.GetFolder(FPath).SubFolders 6 If InStr(Folder.Name, keyword) > 0 Then 7 getTgtPath = Folder.Path: Exit Function 8 Else 9 Call getTgtPath(Folder.Path, keyword) 10 End If 11 Next Folder 12End Function

投稿2020/05/04 14:20

ryuno_vanilla

総合スコア119

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

あなたの回答

tips

太字

斜体

打ち消し線

見出し

引用テキストの挿入

コードの挿入

リンクの挿入

リストの挿入

番号リストの挿入

表の挿入

水平線の挿入

プレビュー

15分調べてもわからないことは
teratailで質問しよう!

ただいまの回答率
85.50%

質問をまとめることで
思考を整理して素早く解決

テンプレート機能で
簡単に質問をまとめる

質問する

関連した質問