Sub ファイル名チェックとメール送信()
Dim folderPath As String
Dim fileList As New Collection
Dim fileName As String
Dim wsFileCheck As Worksheet
Dim wsList As Worksheet
Dim outlookApp As Object
Dim mailItem As Object
Dim invalidFileNames As String
Dim invalidFileNameCount As Integer
' 本Excelのフォルダパスを取得
folderPath = ThisWorkbook.Path & "\"
' 「ファイルチェック」シートと「リスト」シートを取得
Set wsFileCheck = ThisWorkbook.Sheets("ファイルチェック")
Set wsList = ThisWorkbook.Sheets("リスト")
' 指定したパターンのファイルを検索
fileName = Dir(folderPath & "*.pdf")
' 初期化
invalidFileNames = ""
invalidFileNameCount = 0
' ファイルの数だけ繰り返し
Do While fileName <> ""
' ファイル名に「】」が含まれていない場合
If InStr(fileName, "】") = 0 Then
' ファイル名を記録
invalidFileNames = invalidFileNames & fileName & vbCrLf
invalidFileNameCount = invalidFileNameCount + 1
End If
' 次のファイルを取得
fileName = Dir
Loop
' ファイル名に「】」が含まれていないファイルが存在する場合
If invalidFileNameCount > 0 Then
' 警告メッセージを表示
MsgBox invalidFileNameCount & "件のファイル名に「】」が含まれていません。以下のファイルが列挙されます:" & vbCrLf & invalidFileNames, vbExclamation
End If
' 「リスト」シートのA列が0の行を検索し、対応するD列のメールアドレスにメールを送信
For i = 1 To wsList.Cells(wsList.Rows.Count, 1).End(xlUp).Row
If wsList.Cells(i, 1).Value = 0 Then
' Outlookの設定を確認
On Error Resume Next
Set outlookApp = GetObject(, "Outlook.Application")
On Error GoTo 0
' Outlookが起動していない場合は新規に起動
If outlookApp Is Nothing Then
Set outlookApp = CreateObject("Outlook.Application")
End If
' メールアイテムを作成
Set mailItem = outlookApp.CreateItem(0)
' メール送信画面を表示
With mailItem
.To = wsList.Cells(i, 4).Value ' D列のメールアドレスを指定
.Subject = wsList.Cells(i, 5).Value ' E列のサブジェクトを指定
.Body = wsList.Cells(i, 6).Value ' F列のメール本文を指定
.Display ' メール送信画面を表示
End With
Set outlookApp = Nothing
Set mailItem = Nothing
End If
Next i
End Sub
