【エクセルVBA】メール自動作成ツール

Public Const 宛先 As Long = 1
Public Const 氏名 As Long = 2
Public Const 点数 As Long = 3
Public Const 売上 As Long = 4
Public Const 添付キーワード As Long = 2

Sub Outlookメール一括作成()

   '***************変数の宣言***************
   Dim i As Long
   Dim LastRowNum As Long
   Dim mailBody As String
   
   
   'Outlookオブジェクトの作成
   Dim OutlookObj As Outlook.Application
   Set OutlookObj = CreateObject("Outlook.Application")
   
   
   LastRowNum = Cells(1, 1).End(xlDown).Row
   
   For i = 2 To LastRowNum
   
      'メール本文作成
      mailBody = CreateMailBody(i)
   
      'メールアイテムオブジェクト作成
      Dim mailItemObj As Outlook.MailItem
      Set mailItemObj = OutlookObj.CreateItem(olMailItem)
      
      'メール作成
      With mailItemObj
         'Toを設定
         .To = Cells(i, 宛先).Value
         '件名を設定
         .Subject = Range("J1").Value
         '本文を設定
         .Body = mailBody
      End With
      
      Dim keyword As String
      keyword = Cells(i, 添付キーワード)
      
      '添付ファイルオブジェクトの生成
      Dim attachObj As Outlook.Attachments
      Set attachObj = mailItemObj.Attachments
      
      'ファイルを添付する
      Call FileAttach(attachObj, keyword)
      
      '下書きを表示
      mailItemObj.Display
      'mailItemObj.Send  '送信
      
      Set mailItemObj = Nothing
   
   Next i

End Sub
 
Function CreateMailBody(i As Long) As String
 
   Dim Name As String, Point As String, Price As Long
   Dim Body As String
   
   'リストの値を取得
   Name = Cells(i, 氏名).Value
   Point = Cells(i, 点数).Value
   Price = Cells(i, 売上).Value
       
   'メール本文
   Body = Range("J2").Value '初期値を設定
   Body = Replace(Body, "（氏名）", Name)
   Body = Replace(Body, "（点数）", Point)
   Body = Replace(Body, "（売上）", Price)
   
   CreateMailBody = Body
 
End Function

Function FileAttach(attachObj As Object, keyword As String)
    
    Dim FilePath As String
    Dim FileName As String
    
    'ファイルが置いてあるフォルダのパスを取得
    FilePath = Range("I14")
    FileName = Dir(FilePath & "\" & "*")
    
    'フォルダ内の全ファイルに対して検索
    Do While FileName <> ""
        
        'キーワードを含むファイルが見つかったら、下書きアイテムに添付する
        If InStr(FileName, keyword) > 0 Then
            attachObj.Add FilePath & "\" & FileName
        End If
        
        FileName = Dir()
    Loop
    
    Set attachObj = Nothing
 
End Function

Sub Outlookメール一括作成()

   '***************変数の宣言***************
   Dim i As Long
   Dim LastRowNum As Long
   Dim mailBody As String
   
   
   'Outlookオブジェクトの作成
   Dim OutlookObj As Outlook.Application
   Set OutlookObj = CreateObject("Outlook.Application")
   
   
   LastRowNum = Cells(1, 1).End(xlDown).Row
   
   For i = 2 To LastRowNum
   
      'メール本文作成
      mailBody = CreateMailBody(i)
   
      'メールアイテムオブジェクト作成
      Dim mailItemObj As Outlook.MailItem
      Set mailItemObj = OutlookObj.CreateItem(olMailItem)
      
      'メール作成
      With mailItemObj
         'Toを設定
         .To = Cells(i, 宛先).Value
         '件名を設定
         .Subject = Range("J1").Value
         '本文を設定
         .Body = mailBody
      End With
      
      '添付ファイルオブジェクトの生成
      Dim attachObj As Outlook.Attachments
      Set attachObj = mailItemObj.Attachments
      
      'ファイルを添付する
      Dim FilePath As String
      FilePath = Range("I14")
      attachObj.Add FilePath
      
      '下書きを表示
      mailItemObj.Display
      'mailItemObj.Send  '送信
      
      Set mailItemObj = Nothing
   
   Next i

End Sub