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
' 本Excelのフォルダパスを取得
folderPath = ThisWorkbook.Path & "\"
' 「ファイルチェック」シートと「リスト」シートを取得
Set wsFileCheck = ThisWorkbook.Sheets("ファイルチェック")
Set wsList = ThisWorkbook.Sheets("リスト")
' 指定したパターンのファイルを検索
fileName = Dir(folderPath & "*.pdf")
' ファイルの数だけ繰り返し
Do While fileName <> ""
' ファイル名を「ファイルチェック」シートに記録
wsFileCheck.Cells(wsFileCheck.Rows.Count, 2).End(xlUp).Offset(1, 0).Value = fileName
' 次のファイルを取得
fileName = Dir
Loop
' 「リスト」シートの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
