Excelマクロ（vba）でSMTPを介して自動的にメール送付できると何かと便利です。
BASP21でメールを送るのが有名ですが、32bitのExcelでしか動かないのが難点です。
CODを利用すれば64bitでも動くので、そのコードを記載しておきます。
ここのコードをベースにしていますが、呼び出しをシンプルにするために全体的に改良しています。
活用方法
- SendMailCDOというクラスを作り、中に以下のコードを貼り付けます。
'******************************************************************
'■ プロパティ定義
'******************************************************************
Private strFromName As String '差出人名(String)
Private strFromAddr As String '差出人アドレス(String)
Private vntToName As Variant '宛先名(Variant)
Private vntToAddr As Variant '宛先アドレス(Variant)
Private vntCCName As Variant 'CC名(Variant)
Private vntCCAddr As Variant 'CCアドレス(Variant)
Private vntBCCName As Variant 'BCC名(Variant)
Private vntBCCAddr As Variant 'BCCアドレス(Variant)
Private swOwnerBCC As Boolean '差出人BCC指定(Boolean)
Private strSubj As String '件名(String)
Private strBody As String '本文(String)
Private strSign As String '署名(String)
Private vntAttachFile As Variant '添付ファイル名(Variant)
Private strSMTP As String 'SMTPサーバアドレス(String)
Private intPort As Integer 'ポート№(Integer)
Private intTimeOut As Integer 'タイムアウト値(Integer)
Private strLanguageCode As String '文字コード指定(String) 有効値: utf-8, shift-jis, iso-2022-jp, euc-jp
Private intAuthenticate As Integer '認証指定(Integer) 有効値: 0=無し、1=有り
Private blnUseSSL As Boolean 'SSL使用(Boolean)
Private g_strSendUserName As String '認証ユーザーID(String)
Private g_strSendPassword As String '認証パスワード(String)
Private g_strErrMSG As String 'エラーメッセージ(String)
'******************************************************************
'■ プロパティ受付
'******************************************************************
'差出人名(String)
Friend Property Let prpFromName(ByVal Value As String)
strFromName = Value
End Property
'差出人アドレス(String)
Friend Property Let prpFromAddr(ByVal Value As String)
strFromAddr = Value
End Property
'宛先名(Range)
Friend Property Let prpToName(ByVal Value As Range)
vntToName = GetCellsValue(Value)
End Property
'宛先アドレス(Variant)
Friend Property Let prpToAddr(ByVal Value As Range)
vntToAddr = GetCellsValue(Value)
End Property
'CC名(Variant)
Friend Property Let prpCCName(ByVal Value As Range)
vntCCName = GetCellsValue(Value)
End Property
'CCアドレス(Variant)
Friend Property Let prpCCAddr(ByVal Value As Range)
vntCCAddr = GetCellsValue(Value)
End Property
'BCC名(Variant)
Friend Property Let prpBCCName(ByVal Value As Range)
vntBCCName = GetCellsValue(Value)
End Property
'BCCアドレス(Variant)
Friend Property Let prpBCCAddr(ByVal Value As Range)
vntBCCAddr = GetCellsValue(Value)
End Property
'差出人BCC指定(Boolean)
Friend Property Let prpOwnerBCC(ByVal Value As Boolean)
swOwnerBCC = Value
End Property
'件名(String)
Friend Property Let prpSubj(ByVal Value As String)
strSubj = Value
End Property
'本文(String)
Friend Property Let prpBody(ByVal Value As String)
strBody = Value
End Property
'署名(String)
Friend Property Let prpSign(ByVal Value As String)
strSign = Value
End Property
'添付ファイル名(Variant)
Friend Property Let prpAttachFile(ByVal Value As Range)
vntAttachFile = GetCellsValue(Value)
End Property
'SMTPサーバ(String)
Friend Property Let prpSMTP(ByVal Value As String)
strSMTP = Value
End Property
'ポート№(Integer)
Friend Property Let prpPort(ByVal Value As Integer)
intPort = Value
End Property
'タイムアウト値(Integer)
Friend Property Let prpTimeOut(ByVal Value As Integer)
intTimeOut = Value
End Property
'文字コード指定(String) 有効値: utf-8, shift-jis, iso-2022-jp, euc-jp
Friend Property Let prpLanguageCode(ByVal Value As String)
strLanguageCode = Value
End Property
'認証指定(Integer) 有効値: 0=無し、1=有り
Friend Property Let prpAuthenticate(ByVal Value As Integer)
intAuthenticate = Value
End Property
'SSL使用(Boolean)
Friend Property Let prpUseSSL(ByVal Value As Boolean)
blnUseSSL = Value
End Property
'認証ユーザーID(String)
Friend Property Let prpSendUserName(ByVal Value As String)
g_strSendUserName = Value
End Property
'認証パスワード(String)
Friend Property Let prpSendPassword(ByVal Value As String)
g_strSendPassword = Value
End Property
'エラーメッセージ(String)
Friend Property Get prpErrMSG() As String
prpErrMSG = g_strErrMSG
End Property
'******************************************************************
'■ プロパティデフォルト値
'******************************************************************
'パラメータを受け取らなかった場合の初期値
Private Sub Class_Initialize()
swOwnerBCC = False '差出人BCC指定(Boolean)
vntAttachFile = "" '添付ファイル名(Variant)
strSMTP = "" 'SMTPサーバ(String)
intPort = 587 'ポート№(Integer)
intTimeOut = 20 'タイムアウト値(Integer)
strLanguageCode = "utf-8" '文字コード指定(String) 有効値: utf-8, shift-jis, iso-2022-jp, euc-jp
intAuthenticate = 1 '認証指定(Integer) 有効値: 0=無し、1=有り
blnUseSSL = False 'SSL使用(Boolean)
g_strErrMSG = "" 'エラーメッセージ(String)
End Sub
'******************************************************************
'■ メール送信（メイン処理）
'******************************************************************
Friend Function SendMail() As Boolean
SendMail = False
'プロパティ項目チェック
If CheckProperty() = False Then Exit Function
'氏名とメールアドレスの結合（複数メールアドレス可）
Dim strMailFrom As String ' 差出人
strMailFrom = JointMailAddress(strFromName, strFromAddr)
Dim strMailTo As String ' 宛先
strMailTo = JointMailAddress(vntToName, vntToAddr)
Dim strMailCc As String ' CC
strMailCc = JointMailAddress(vntCCName, vntCCAddr)
Dim strMailBcc As String ' BCC
If swOwnerBCC Then
strMailBcc = JointMailAddress(vntBCCName, vntBCCAddr) & "," & JointMailAddress(strFromName, strFromAddr)
Else
strMailBcc = JointMailAddress(vntBCCName, vntBCCAddr)
End If
'件名から改行コードの削除
strSubj = Replace(Trim(strSubj), vbCrLf, "")
strSubj = Replace(Trim(strSubj), vbCr, "")
strSubj = Replace(Trim(strSubj), vbLf, "")
'本文の改行コードを統一し最後に改行を追加
strBody = Replace(Trim(strBody), vbCrLf, vbLf)
strBody = Replace(strBody, vbCr, vbLf)
If Right(strBody, 2) <> vbLf Then
strBody = strBody & vbLf
End If
'署名がある場合は本文に追加
If strSign <> "" Then
If Right(strBody, 4) <> vbLf & vbLf Then
strBody = strBody & vbLf
End If
strBody = strBody & strSign
End If
'メール送信
Dim objCDO As New CDO.Message
On Error Resume Next
With objCDO
With .Configuration.Fields
.Item(cdoSendUsingMethod) = cdoSendUsingPort
.Item(cdoSMTPServer) = strSMTP 'SMTPサーバ名
.Item(cdoSMTPServerPort) = intPort 'ポート№
.Item(cdoSMTPConnectionTimeout) = intTimeOut 'タイムアウト
.Item(cdoLanguageCode) = strLanguageCode '文字コード指定
.Item(cdoSMTPAuthenticate) = intAuthenticate '認証指定
If intAuthenticate = 1 Then
.Item(cdoSendUserName) = g_strSendUserName '認証ユーザー
.Item(cdoSendPassword) = g_strSendPassword '認証パスワード
.Item(cdoSMTPUseSSL) = blnUseSSL 'SSL指定
End If
.Update
End With
.MimeFormatted = True
.Fields.Update
.From = strMailFrom '送信者
.To = strMailTo '宛先
If strMailCc <> "" Then .CC = strMailCc 'CC
If strMailBcc <> "" Then .BCC = strMailBcc 'BCC
.Subject = strSubj '件名
.TextBody = strBody '本文
.TextBodyPart.Charset = strLanguageCode '文字コード指定
If IsArray(vntAttachFile) Then '添付ファイルの登録(複数対応)
Dim lngIx As Long
Do While lngIx <= UBound(vntAttachFile)
.AddAttachment Trim(vntAttachFile(lngIx))
lngIx = lngIx + 1
Loop
ElseIf vntAttachFile <> "" Then
.AddAttachment Trim(vntAttachFile)
End If
.Send
End With
Set objCDO = Nothing
'エラー判定
If Err.Number <> 0 Then
g_strErrMSG = "メール送信に失敗しました。" & vbCrLf & Err.Description
End If
On Error GoTo 0
'成否判定を返す
SendMail = g_strErrMSG = ""
End Function
'******************************************************************
'■ 関数
'******************************************************************
'------------------------------------------------------------------
' 関数処理：プロパティチェック
' 引数 ：(なし)
' 返り値 ：処理成否(Boolean)
'------------------------------------------------------------------
Private Function CheckProperty() As Boolean
CheckProperty = False
'差出人チェック
If strFromAddr = "" Then
g_strErrMSG = "「差出人アドレス」が指定されていません。"
Exit Function
End If
' 宛先チェック
If IsArray(vntToAddr) = False Then
If vntToAddr = "" Then
g_strErrMSG = "「宛先アドレス」が指定されていません。"
Exit Function
End If
End If
'件名チェック
If strSubj = "" Then
g_strErrMSG = "「件名」が指定されていません。"
Exit Function
End If
'本文チェック
If strBody = "" Then
g_strErrMSG = "「本文」が指定されていません。"
Exit Function
End If
'添付ファイル存在チェック
Dim objFso As New FileSystemObject
'複数ファイルの場合
If IsArray(vntAttachFile) Then
Dim lngIx As Long
Do While lngIx <= UBound(vntAttachFile)
If objFso.FileExists(Trim(vntAttachFile(lngIx))) = False Then
g_strErrMSG = "指定のファイルが実在しません。" & vbCrLf & Trim(vntAttachFile(lngIx))
Exit Function
End If
lngIx = lngIx + 1
Loop
'単一ファイルの場合
ElseIf vntAttachFile <> "" Then
If objFso.FileExists(Trim(vntAttachFile)) = False Then
g_strErrMSG = "指定のファイルが実在しません。" & vbCrLf & Trim(vntAttachFile)
Exit Function
End If
End If
Set objFso = Nothing
'認証関連チェック
If intAuthenticate = 1 Then
If g_strSendUserName = "" Then
g_strErrMSG = "「アカウント(詳細情報)」が指定されていません。"
Exit Function
End If
If g_strSendPassword = "" Then
g_strErrMSG = "「パスワード(詳細情報)」が指定されていません。"
Exit Function
End If
End If
CheckProperty = True
End Function
'------------------------------------------------------------------
' 関数処理：Range内のデータが1つであればStringに、複数であれば配列にする
' 引数 ：Arg1 = セル範囲(Range)
' Arg2 = 最終行(Long) *Optional
' 返り値 ：処理成否(Boolean)
'------------------------------------------------------------------
Private Function GetCellsValue(ByRef objR As Range) As Variant
'列取得
Dim lngCol As Long
lngCol = objR.Cells(1).Column
'先頭行の取得
Dim lngRowStart As Long
lngRowStart = objR.Cells(1).Row
'最終行の取得
Dim lngRowEnd As Long
lngRowEnd = lngRowStart + objR.Rows.Count - 1
lngRowEnd = Cells(lngRowEnd + 1, lngCol).End(xlUp).Row
'未入力の場合
If lngRowEnd < lngRowStart Then
GetCellsValue = ""
'1件の場合
ElseIf lngRowEnd = lngRowStart Then
GetCellsValue = Trim(Cells(lngRowStart, lngCol).Value)
'複数件の場合
Else
Dim tblText() As String '配列
ReDim tblText(0)
Dim lngIx As Long: lngIx = -1 '配列index
Dim strText As String '確認するセルの値
Dim lngRow As Long '確認する列
For lngRow = lngRowStart To lngRowEnd
strText = Trim(Cells(lngRow, lngCol).Value)
If strText <> "" Then
lngIx = lngIx + 1
ReDim Preserve tblText(lngIx)
tblText(lngIx) = strText
End If
Next lngRow
Select Case lngIx
Case -1
GetCellsValue = ""
Case 0
GetCellsValue = tblText(0)
Case Else
GetCellsValue = tblText
End Select
End If
End Function
'------------------------------------------------------------------
' 関数処理：氏名とメールアドレスを結合（複数の場合はカンマで区切る）
' 引数 ：Arg1 = 名称(Variant)
' Arg2 = アドレス(Variant)
' 返り値 ：接合後アドレス(String)
'------------------------------------------------------------------
Private Function JointMailAddress(ByVal vntName As Variant, _
ByVal vntEmail As Variant) As String
Dim strName As String '名称
Dim strEmail As String 'アドレス
'アドレスがRange配列(複数指定)の場合
If IsArray(vntEmail) Then
Dim lngIx As Long '配列index
Dim lngIxMax1 As Long '配列index上限(名称)
Dim lngIxMax2 As Long '配列index上限(アドレス)
Dim strAddr As String '編集後アドレス
strAddr = ""
lngIxMax2 = UBound(vntEmail)
ReDim tblAddr(lngIxMax2)
'名称もRange配列(複数指定)か
If IsArray(vntName) Then
lngIxMax1 = UBound(vntName)
Else
lngIxMax1 = -1
End If
'配列を巡回
Do While lngIx <= lngIxMax2
strEmail = Trim(vntEmail(lngIx))
'名称は要素数を判定してセット
If lngIxMax1 >= lngIxMax2 Then
strName = Trim(vntName(lngIx))
Else
strName = ""
End If
'2件目以降はカンマで区切る
If strAddr <> "" Then
strAddr = strAddr & ","
End If
'アドレスのみか
If strName = "" Then
strAddr = strAddr & strEmail
Else
strAddr = strAddr & strName & " <" & strEmail & ">"
End If
lngIx = lngIx + 1
Loop
JointMailAddress = strAddr
'アドレスが単一の場合
Else
strName = ""
strEmail = ""
'Variant項目チェック
If VarType(vntName) = vbString Then strName = Trim(vntName)
If VarType(vntEmail) = vbString Then strEmail = Trim(vntEmail)
'アドレスのみか
If strName = "" Then
JointMailAddress = strEmail
Else
JointMailAddress = strName & " <" & strEmail & ">"
End If
End If
End Function
- 以下の2つの参照設定を有効化します。
Microsoft CDO for Windows 2000 Library
Microsoft Scripting Runtime
- あとは任意のプロシージャでクラスを叩くだけです。
SMTPサーバなどパラメータで指定しなければクラスで定義した標準値が使用されます。
With New SendMailCDO
.prpFromName = "" '差出人(String)
.prpFromAddr = "" '差出人アドレス(String)
.prpToName = Range("$I$3:$I$100") '宛先名(Range)
.prpToAddr = Range("$J$3:$J$100") '宛先アドレス(Range)
.prpCCName = Range("$K$3:$K$100") 'CC名(Range)
.prpCCAddr = Range("$L$3:$L$100") 'CCアドレス(Range)
.prpBCCName = Range("$M$3:$M$100") 'BCC名(Range)
.prpBCCAddr = Range("$N$3:$N$100") 'BCCアドレス(Range)
.prpOwnerBCC = Cells(30, 2).Value = "送信者をBCCに加える" '差出人BCC指定(String)
.prpAttachFile = Range("$B$25:$H$29") '添付ファイル名(Range)
.prpSubj = Cells(8, 2).Value '件名(String)
.prpBody = Cells(9, 2).Value '本文(String)
.prpSign = Cells(20, 2).Value '署名(String)
.prpSMTP = "" 'SMTPサーバアドレス(String)
.prpPort = 587 'ポート№(Integer)
.prpAuthenticate = 1 '認証指定(Integer) 0=無し、1=有り
.prpUseSSL = False 'SSL使用(Boolean)
.prpSendUserName = "S00000000" '認証ユーザーID(String)
.prpSendPassword = "pass" '認証パスワード(String)
If .SendMail = False Then
MsgBox .prpErrMSG, vbCritical
End If
End With