一気にメール送信

同報メール送信のソースコードを示します。
メルマガと連動していますので、必要に応じてご確認をお願いします。

Option Explicit

Sub Send_SimilarMail()

  '基本情報の配置先をConstとして宣言 (7/1メルマガ)
  Const MAIL_BODY = "B1"
  Const MAIL_TITLE = "B2"
  Const MAIL_FROM = "B3"
  Const MAIL_CC = "B4"
  Const MAIL_SERVER = "B5"
  
  '送付先情報の先頭行を宣言 (7/1メルマガ)
  Const SEND_TABLE = "A10"
  Const COLUMN_MAX = 5 '送信先情報の最大列
  Const ADDR_COL = 3

  '送信先の最大行
  Dim row_max As Long
  Dim table_row As Long

  '汎用的な変数
  Dim I As Long
  Dim J As Long
  Dim Hantei As Integer
  
  '送信するメール関連の情報
  Dim s_address As String
  Dim s_body As String
  Dim s_title As String
  Dim s_cc As String
  Dim s_from As String

  'メール送信関係の設定(7/8メルマガ)
  Dim Mail As Object
  Dim cdoConfigPrefix As String
  cdoConfigPrefix = "http://schemas.microsoft.com/cdo/configuration/"
  Set Mail = CreateObject("CDO.Message")
  
  '送信先の先頭行を取得(7/5メルマガ)
  table_row = Range(SEND_TABLE).Row
  
  '値が記入されている行の最大行を取得(7/5メルマガ)
  row_max = Range(SEND_TABLE).End(xlDown).Row
  
  '1行ずつ処理を行いメール送信する(7/6メルマガ)
  For I = Range(SEND_TABLE).Row + 1 To row_max
    
    'B1に記載されているメール本文を取得(7/4メルマガ)
    s_body = Range(MAIL_BODY)
    
    'B2に記載されているメールタイトルを取得(7/4メルマガ)
    s_title = Range(MAIL_TITLE)
    
    '送信先のアドレスを取得(7/4メルマガ)
    s_address = Cells(I, ADDR_COL)
    
    '送信元(自分自身)のアドレスを取得(7/4メルマガ)
    s_from = Range(MAIL_FROM)
    
    'CCとして送付するアドレスを取得(7/4メルマガ)
    s_cc = Range(MAIL_CC)
        
    
    'メール本文とタイトルを作成(文字置換)(7/6、7/7メルマガ)
    For J = 1 To COLUMN_MAX
      If Cells(I, J) <> "" Then
        s_body = Replace(s_body, Cells(table_row, J), Cells(I, J))
        s_title = Replace(s_title, Cells(table_row, J), Cells(I, J))
      End If
    Next J
  
    '送信準備(メールオブジェクトに、送信する情報を格納)(7/11メルマガ)
    With Mail
      .From = s_from
      .To = s_address
      .Cc = s_cc
      .Bcc = ""
      .Subject = s_title
      .HTMLBody = s_body
      .TextBodyPart.Charset = "ISO-2022-JP"
       With .Configuration.Fields
            .Item(cdoConfigPrefix & "sendusing") = 2   'cdoSendUsingPort ' 外部SMTP指定
            .Item(cdoConfigPrefix & "smtpserver") = Range(MAIL_SERVER)
            .Item(cdoConfigPrefix & "smtpserverport") = 465
            .Item(cdoConfigPrefix & "smtpconnectiontimeout") = 60    ' タイムアウト
            .Item(cdoConfigPrefix & "smtpauthenticate") = 1    ' 認証あり(※)
            .Item(cdoConfigPrefix & "sendusername") = "XXXXXXX"          ' ユーザー(※)
            .Item(cdoConfigPrefix & "sendpassword") = "XXXXXXX"        ' パスワード(※)
            .Item(cdoConfigPrefix & "smtpusessl") = True               ' SSL指定(※)
       End With
    End With
    Call Mail.Configuration.Fields.Update
  
    '確認後に送信する (7/12メルマガ)
    Hantei = MsgBox("メールタイトル：" & s_title & _
                    vbCrLf & vbCrLf & "メール本文：" & vbCrLf & s_body, vbOKCancel, "送信内容")
    If Hantei = 1 Then
      'Call Mail.Send  'コメントアウトしています。サーバ、送信先のテストが完了してから実行してください。
      MsgBox "送信完了！"
    Else
      MsgBox "メール未送信"
    End If
  
  Next I
 

End Sub
</code>

100

101

102

103

104

105

106

107

108

Option Explicit

Sub Send_SimilarMail()

'基本情報の配置先をConstとして宣言 (7/1メルマガ)

Const MAIL_BODY = "B1"

Const MAIL_TITLE = "B2"

Const MAIL_FROM = "B3"

Const MAIL_CC = "B4"

Const MAIL_SERVER = "B5"

'送付先情報の先頭行を宣言 (7/1メルマガ)

Const SEND_TABLE = "A10"

Const COLUMN_MAX = 5 '送信先情報の最大列

Const ADDR_COL = 3

'送信先の最大行

Dim row_max As Long

Dim table_row As Long

'汎用的な変数

Dim I As Long

Dim J As Long

Dim Hantei As Integer

'送信するメール関連の情報

Dim s_address As String

Dim s_body As String

Dim s_title As String

Dim s_cc As String

Dim s_from As String

'メール送信関係の設定(7/8メルマガ)

Dim Mail As Object

Dim cdoConfigPrefix As String

cdoConfigPrefix = "http://schemas.microsoft.com/cdo/configuration/"

Set Mail = CreateObject("CDO.Message")

'送信先の先頭行を取得(7/5メルマガ)

table_row = Range(SEND_TABLE).Row

'値が記入されている行の最大行を取得(7/5メルマガ)

row_max = Range(SEND_TABLE).End(xlDown).Row

'1行ずつ処理を行いメール送信する(7/6メルマガ)

For I = Range(SEND_TABLE).Row + 1 To row_max

'B1に記載されているメール本文を取得(7/4メルマガ)

s_body = Range(MAIL_BODY)

'B2に記載されているメールタイトルを取得(7/4メルマガ)

s_title = Range(MAIL_TITLE)

'送信先のアドレスを取得(7/4メルマガ)

s_address = Cells(I, ADDR_COL)

'送信元(自分自身)のアドレスを取得(7/4メルマガ)

s_from = Range(MAIL_FROM)

'CCとして送付するアドレスを取得(7/4メルマガ)

s_cc = Range(MAIL_CC)

'メール本文とタイトルを作成(文字置換)(7/6、7/7メルマガ)

For J = 1 To COLUMN_MAX

If Cells(I, J) <> "" Then

s_body = Replace(s_body, Cells(table_row, J), Cells(I, J))

s_title = Replace(s_title, Cells(table_row, J), Cells(I, J))

End If

Next J

'送信準備(メールオブジェクトに、送信する情報を格納)(7/11メルマガ)

With Mail

.From = s_from

.To = s_address

.Cc = s_cc

.Bcc = ""

.Subject = s_title

.HTMLBody = s_body

.TextBodyPart.Charset = "ISO-2022-JP"

With .Configuration.Fields

.Item(cdoConfigPrefix & "sendusing") = 2 'cdoSendUsingPort ' 外部SMTP指定

.Item(cdoConfigPrefix & "smtpserver") = Range(MAIL_SERVER)

.Item(cdoConfigPrefix & "smtpserverport") = 465

.Item(cdoConfigPrefix & "smtpconnectiontimeout") = 60 ' タイムアウト

.Item(cdoConfigPrefix & "smtpauthenticate") = 1 ' 認証あり(※)

.Item(cdoConfigPrefix & "sendusername") = "XXXXXXX" ' ユーザー(※)

.Item(cdoConfigPrefix & "sendpassword") = "XXXXXXX" ' パスワード(※)

.Item(cdoConfigPrefix & "smtpusessl") = True ' SSL指定(※)

End With

Call Mail.Configuration.Fields.Update

'確認後に送信する (7/12メルマガ)

Hantei = MsgBox("メールタイトル：" & s_title & _

vbCrLf & vbCrLf & "メール本文：" & vbCrLf & s_body, vbOKCancel, "送信内容")

If Hantei = 1 Then

'Call Mail.Send 'コメントアウトしています。サーバ、送信先のテストが完了してから実行してください。

MsgBox "送信完了！"

Else

MsgBox "メール未送信"

End If

Next I

End Sub

</code>

MENU

VBA関連

VBA関連