下記のコードを追加してください。
|
Private Sub ExAllSendMail(lrow As Long)
Dim sret As String
Dim szServer As String 'SMTPサーバー名
Dim szFrom As String '送信元
Dim szTo As String '宛先
Dim szSubject As String '件名
Dim szBody As String '本文
Dim szFile As String '添付ファイル
Dim i As Long
szServer = Range("J7") & ":" & Range("M7")
If Range("J6") = "" Then
szFrom = Range("JI8")
Else
szFrom = Range("J6") & "<" & Range("J8") & ">"
End If
szSubject = Range("J10")
szBody = Range("J11")
szFile = ""
On Error GoTo ErrEnd
For i = 7 To lrow
'送信マークとアドレスの確認
If Cells(i, 2) = 1 And Cells(i, 4) <> "" Then
Cells(i, 5) = ""
Cells(i, 6) = "送信中！！"
Cells(i, 6).Font.Color = RGB(255, 0, 0)
'宛名
If Cells(i, 3) = "" Then
szTo = Cells(i, 3)
Else
szTo = Cells(i, 3) & "<" & Cells(i, 4) & ">"
End If
sret = SendMail(szServer, szTo, szFrom, szSubject, szBody, szFile)
Cells(i, 6).Font.Color = RGB(0, 0, 0)
'送信エラーの場合
If Len(sret) <> 0 Then
Cells(i, 5) = "Error"
Cells(i, 6) = sret
Else
Cells(i, 5) = Format(Now, "yyyy/mm/dd hh:nn:ss")
Cells(i, 6) = ""
End If
End If
Next
Exit Sub
ErrEnd:
Range("E2") = ""
MsgBox "送信中にエラーが発生しました。処理を中止します。" & vbCrLf & Err.Description, , "一斉メール送信"
End Sub
|
|
|
下記のコードに変更してください。
|
Private Sub CommandButton2_Click()
Dim lrow As Long
'送信設定値のチェック
If ExDataCheck = False Then
Exit Sub
End If
'送信先アドレスの最終行を調べる
lrow = ActiveSheet.Range("D65536").End(xlUp).Row
If lrow = 6 Then
MsgBox "送信先アドレスは最低１件は入力してください。", , "一斉メール送信"
End If
'一斉メール送信
ExAllSendMail lrow
End Sub
|
|
|
|
