Excel Mail Send

[MatsuLingさん]

Sub Excel_Mail_Send()

' 変数設定
Dim iMsg As Object
Dim iConf As Object
Dim strbody As String
Dim Flds As Variant
Dim i, LastRow As Integer

' CDOオブジェクト初期設定
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")

iConf.Load -1 ' CDO Source Defaults
Set Flds = iConf.Fields
With Flds
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = Worksheets("Sheet1").Range("C2").Value
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = Worksheets("Sheet1").Range("C3").Value
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = True
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = Worksheets("Sheet1").Range("C6").Value
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = Worksheets("Sheet1").Range("C7").Value
.Update
End With


' 送信範囲設定
LastRow = Worksheets("Sheet1").Range("B9").End(xlDown).Row

' メール送信ループ
For i = 10 To LastRow

' 送信状況メッセージクリア
Worksheets("Sheet1").Range("F2").Value = ""

' メール本文作成
strbody = Worksheets("Sheet1").Range("F" & i).Value

' 改行変換（送信環境によってはここの修正が必要かも）
tmpstrbody = Replace(strbody, vbLf, vbCrLf)
strbody = Replace(tmpstrbody, vbCr & vbCrLf, vbCrLf)

' メール送信
With iMsg
Set .Configuration = iConf
.From = Worksheets("Sheet1").Range("C4").Value
.To = Worksheets("Sheet1").Range("B" & i).Value
.BCC = Worksheets("Sheet1").Range("C5").Value
.Subject = Worksheets("Sheet1").Range("C" & i).Value
.BodyPart.Charset = "utf-8"
.TextBody = strbody
.Send
End With

' 送信状況メッセージ更新
Worksheets("Sheet1").Range("F2").Value = Worksheets("Sheet1").Range("B" & i).Value & " まで送信成功！"

' ３秒停止
Application.Wait [ NOW() + "0:00:03" ]

Next i

End Sub