ダウンロード(メール送信：外部コンポーネント利用)

マクロ上でデータファイルを添付してメールを自動送信するプロシージャをモジュールでインポートして利用できるものを用意しました。

「BASP21」は64ビット版Excelの対応はありません。このページで紹介している「BASP21」はかなり古くからあるコンポーネントなのですが、コンポーネント自体に64ビット版の提供がないため、64ビット版Excelでの利用はできません。

64ビット版Excelでのメール送信については「CDO」をご利用下さい。

インストールしたメールソフトを経由せずにメールを送信します。

ここで紹介する「BASP21」というコンポーネントはメールの送受信の他、Webサーバサイドでファイルのアップロードの受け取り側の処理を行なうなどの機能があります。このページではメールの送信のみの説明になりますが、送信のみであれば現在では次ページで紹介している「CDO」の方が優勢なのかも知れません。
「CDO」と同様のサンプルを用意してみました。但し、こちらの「BASP21」では暗号化を含めた送信認証については網羅していません。

(画像をクリックすると、このサンプルがダウンロードできます)

メール送信で「BASP21」を扱う中核部分は「BASP21メール送信クラス(clsSendMailByBASP21.cls)」としており、ほとんどのメール送信のケースでそのままインポ－トして変更せずに利用できると思います。ここではまず、「BASP21メール送信クラス(clsSendMailByBASP21.cls)」を呼び出している側のシートモジュール(Sheet1)のコードを紹介します。


'***************************************************************************************************
'   メール送信機能(BSMTP.dll:BASP21)                        Sheet1(Class)
'
'   作成者:井上治  URL:https://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'***************************************************************************************************
' 変更日付 Rev   変更履歴内容---------------------------------------------------------------------->
' 04/11/06(1.0.0)新規作成
' 17/10/01(2.0.0)クラス化移行､LHA⇒ZIP変更､ダイアルアップ関連記述廃止
' 17/10/09(2.0.0)セルからの件名、本文編集用プロシージャをクラス側に移動する対応
'***************************************************************************************************
Option Explicit
'===================================================================================================
Private Const g_cnsTitle As String = "メール送信機能(BSMTP.dll:BASP21)"

'***************************************************************************************************
'   ■■■ ワークシートイベント ■■■
'***************************************************************************************************
'* 処理名　：CommandButton1_Click
'* 機能　　：｢メール送信｣ボタンクリックイベント
'---------------------------------------------------------------------------------------------------
'* 返り値　：(なし)
'* 引数　　：(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2014年11月06日
'* 作成者　：井上　治
'* 更新日　：2017年10月09日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Private Sub CommandButton1_Click()
    '-----------------------------------------------------------------------------------------------
    Dim vntToName As Variant                                        ' 宛先名
    Dim vntToAddr As Variant                                        ' 宛先アドレス
    Dim vntCCName As Variant                                        ' CC名
    Dim vntCCAddr As Variant                                        ' CCアドレス
    Dim vntBCCName As Variant                                       ' BCC名
    Dim vntBCCAddr As Variant                                       ' BCCアドレス
    Dim swOwnerBCC As Boolean                                       ' 差出人BCC指定
    Dim strSubj As String                                           ' 件名
    Dim strBody As String                                           ' 本文
    Dim vntAttachFile As Variant                                    ' 添付ファイル名
    '-----------------------------------------------------------------------------------------------
    vntToName = FP_GetCellsValue(Range("$I$3:$I$1048576"))
    vntToAddr = FP_GetCellsValue(Range("$J$3:$J$1048576"))
    vntCCName = FP_GetCellsValue(Range("$K$3:$K$1048576"))
    vntCCAddr = FP_GetCellsValue(Range("$L$3:$L$1048576"))
    vntBCCName = FP_GetCellsValue(Range("$M$3:$M$1048576"))
    vntBCCAddr = FP_GetCellsValue(Range("$N$3:$N$1048576"))
    swOwnerBCC = Cells(31, 2).Value = "送信者をBCCに加える"
    vntAttachFile = FP_GetCellsValue(Range("$B$26:$H$30"), 31)
    '-----------------------------------------------------------------------------------------------
    ' BASP21メール送信クラス(clsSendMailByBASP21)の呼び出し
    With New clsSendMailByBASP21
        .prpDomain = Trim(Cells(3, 2).Value)                        ' ドメイン
        .prpSMTP = Trim(Cells(4, 2).Value)                          ' SMTPサーバ
        .prpPort = Cells(5, 2).Value                                ' ポート№
        .prpTimeOut = Cells(6, 2).Value                             ' タイムアウト
        .prpFromName = Trim(Cells(7, 2).Value)                      ' 差出人
        .prpFromAddr = Trim(Cells(8, 2).Value)                      ' 〃アドレス
        ' 件名、本文の編集(改行調整等)
        strSubj = .EditSubj(Cells(9, 2).Value)
        strBody = .EditBody(Cells(10, 2).Value, Cells(21, 2).Value)
        ' メール送信メソッド
        If Not .SendMailByBASP21(vntToName, _
                                 vntToAddr, _
                                 vntCCName, _
                                 vntCCAddr, _
                                 vntBCCName, _
                                 vntBCCAddr, _
                                 swOwnerBCC, _
                                 strSubj, _
                                 strBody, _
                                 vntAttachFile) Then
            '処理失敗
            MsgBox .prpErrMSG, vbCritical, g_cnsTitle
        End If
    End With
End Sub

'***************************************************************************************************
'* 処理名　：CommandButton2_Click
'* 機能　　：｢添付ファイルの参照登録｣ボタンクリックイベント
'---------------------------------------------------------------------------------------------------
'* 返り値　：(なし)
'* 引数　　：(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2014年11月06日
'* 作成者　：井上　治
'* 更新日　：2017年10月01日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Private Sub CommandButton2_Click()
    '-----------------------------------------------------------------------------------------------
    ' ユーザーフォーム起動
    g_lngTblEntFileMax = -1
    UF_EntFiles.Show
    Unload UF_EntFiles
    If g_lngTblEntFileMax < 0 Then Exit Sub
    ' 5件超の場合は10件に修正
    If g_lngTblEntFileMax > 4 Then g_lngTblEntFileMax = 4
    '-----------------------------------------------------------------------------------------------
    Dim lngRow As Long                                              ' 行INDEX
    Dim lngIx As Long                                               ' テーブルINDEX
    Range("$B$26:$H$30").ClearContents
    lngRow = 25
    ' 今回ドラッグされたファイルを登録
    Do While lngIx <= g_lngTblEntFileMax
        lngRow = lngRow + 1
        Cells(lngRow, 2).Value = g_tblEntFile(lngIx)
        ' 次へ
        lngIx = lngIx + 1
    Loop
    ThisWorkbook.Saved = True
End Sub

'***************************************************************************************************
'   ■■■ サブ処理(Pirvate) ■■■
'***************************************************************************************************
'* 処理名　：FP_GetCellsValue
'* 機能　　：セル範囲の値の受け取り
'---------------------------------------------------------------------------------------------------
'* 返り値　：名称(アドレス)(Variant)
'* 引数　　：Arg1 = 対象セル範囲(Range)
'* 　　　　　Arg2 = 範囲最終行(Long)                    ※Option
'---------------------------------------------------------------------------------------------------
'* 作成日　：2017年10月01日
'* 作成者　：井上　治
'* 更新日　：2017年10月01日
'* 更新者　：井上　治
'* 機能説明：単一行の場合は文字列、複数行の場合は配列を返す
'* 注意事項：
'***************************************************************************************************
Private Function FP_GetCellsValue(ByRef objR As Range, _
                                  Optional ByVal lngLastRow As Long = 1048576) As Variant
    '-----------------------------------------------------------------------------------------------
    Dim lngRow As Long                                              ' 行INDEX
    Dim lngRowF As Long                                             ' 行INDEX先頭
    Dim lngRowT As Long                                             ' 行INDEX最終
    Dim lngCol As Long                                              ' カラムINDEX
    lngRowF = objR.Cells(1).Row
    lngCol = objR.Cells(1).Column
    lngRowT = Cells(lngLastRow, lngCol).End(xlUp).Row
    ' 未入力か
    If lngRowT < lngRowF Then
        ' 未入力
        FP_GetCellsValue = ""
    ElseIf lngRowT = lngRowF Then
        ' 1件のみ
        FP_GetCellsValue = Trim(Cells(lngRowF, lngCol).Value)
    Else
        ' 複数登録
        Dim lngIx As Long                                           ' テーブルINDEX
        Dim strText As String                                       ' テキストWORK
        Dim tblText() As String                                     ' 配列
        lngIx = -1
        ReDim tblText(0)
        ' 対象セルの行範囲を巡回
        For lngRow = lngRowF To lngRowT
            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
                FP_GetCellsValue = ""
            Case 0
                FP_GetCellsValue = tblText(0)
            Case Else
                FP_GetCellsValue = tblText
        End Select
    End If
End Function

'------------------------------------------<< End of Source >>--------------------------------------

シート上の「メール送信」ボタンをクリックした時のイベントが「CommandButton1_Click」で、そのうち、クラスモジュール(clsSendMailByBASP21.cls)を呼び出しているのは後半の「With New clsSendMailByBASP21」以降です。
送信サーバ設定と差出人情報はプロパティ設定としており、宛先、件名、本文、添付ファイル等はメール送信メソッド「SendMailByBASP21」の引数指定としています。
今回のサンプルは宛先、CC、BCC、添付ファイルとも複数指定ができるようにしてあるためやや複雑に見えるかもしれませんが、実際の送信部分は省略できる既定値とCC、BCCを除外してしまえば10行程度で済んでしまうものです。
メール送信メソッド(SendMailByBASP21)の処理失敗時は、プロパティ側からエラーメッセージを受け取ってメッセージボックスに表示させています。

なお、「添付ファイルの参照登録」の機能も本ワークブックに持ち込んでありますが、メール送信の主機能の説明から外れるのでコードの紹介はしておりません。関心がある方はダウンロードさせたプロジェクト内部をご覧下さい。

送信の「中核部分」の「BASP21メール送信クラス(clsSendMailByBASP21.cls)」です。


'***************************************************************************************************
'   メール送信機能(BSMTP.dll:BASP21)                        clsSendMailByBASP21(Class)
'
'   作成者:井上治  URL:https://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'***************************************************************************************************
'   [参照設定]
'   ・Microsoft Scripting Runtime
'***************************************************************************************************
' 変更日付 Rev   変更履歴内容---------------------------------------------------------------------->
' 04/11/06(1.0.0)新規作成
' 17/10/01(2.0.0)クラス化移行、ファイル圧縮・ダイアルアップ関連記述廃止
' 17/10/03(2.0.0)ドメインを省略可とする対応
' 17/10/09(2.0.0)セルからの件名、本文編集用プロシージャの追加
'***************************************************************************************************
Option Explicit
'===================================================================================================
Private Const g_cnsTitle As String = "メール送信機能(BSMTP.dll:BASP21)"
' フォルダパス文字数上限
Private Const g_cnsMaxPath As Long = 260
'---------------------------------------------------------------------------------------------------
' メール送信API(BSMTP.dll:BASP21)
Private Declare Function SendMail Lib "BSMTP.dll" _
    (ByVal szServer As String, _
     ByVal szTo As String, _
     ByVal szFrom As String, _
     ByVal szSubject As String, _
     ByVal szBody As String, _
     ByVal szFile As String) As String
' SYSTEMディレクトリ名取得
Private Declare Function GetSystemDirectory Lib "KERNEL32.dll" Alias "GetSystemDirectoryA" _
    (ByVal lpBuffer As String, ByVal nSize As Long) As Long
'---------------------------------------------------------------------------------------------------
' プロパティから引き渡される変数
Private g_strDomain As String                                       ' ドメインアドレス
Private g_strSMTP As String                                         ' SMTPサーバアドレス
Private g_intPort As Integer                                        ' ポート№
Private g_intTimeOut As Integer                                     ' タイムアウト値
Private g_strFromName As String                                     ' 差出人名
Private g_strFromAddr As String                                     ' 差出人アドレス
Private g_strErrMSG As String                                       ' エラーメッセージ

'***************************************************************************************************
'   ■■■ クラス初期化 ■■■
'***************************************************************************************************
'* 処理名　：Class_Initialize
'* 機能　　：クラス初期化
'---------------------------------------------------------------------------------------------------
'* 返り値　：(なし)
'* 引数　　：(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2017年10月01日
'* 作成者　：井上　治
'* 更新日　：2017年10月01日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Private Sub Class_Initialize()
    '-----------------------------------------------------------------------------------------------
    ' ポート№､タイムアウト値の初期値投入
    g_intPort = 25
    g_intTimeOut = 60
End Sub

'***************************************************************************************************
'   ■■■ 外部からの呼び出しプロシージャ(Friend) ■■■
'***************************************************************************************************
'* 処理名　：SendMailByBASP21
'* 機能　　：メール送信(BSMTP.dll:BASP21)
'---------------------------------------------------------------------------------------------------
'* 返り値　：処理成否(Boolean)
'* 引数　　：Arg1 = 宛先名(Variant)                         ※複数の場合は配列をセット
'* 　　　　　Arg2 = 宛先アドレス(Variant)                   ※複数の場合は配列をセット
'* 　　　　　Arg3 = CC名(Variant)                           ※複数の場合は配列をセット
'* 　　　　　Arg4 = CCアドレス(Variant)                     ※複数の場合は配列をセット
'* 　　　　　Arg5 = BCC名(Variant)                          ※複数の場合は配列をセット
'* 　　　　　Arg6 = BCCアドレス(Variant)                    ※複数の場合は配列をセット
'* 　　　　　Arg7 = 差出人BCC指定(Boolean)
'* 　　　　　Arg8 = 件名(String)
'* 　　　　　Arg9 = 本文(String)
'* 　　　　　Arg10= 添付ファイル名(Variant)                 ※複数の場合は配列をセット(Option)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2004年11月06日
'* 作成者　：井上　治
'* 更新日　：2017年10月01日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Friend Function SendMailByBASP21(ByVal vntToName As Variant, _
                                 ByVal vntToAddr As Variant, _
                                 ByVal vntCCName As Variant, _
                                 ByVal vntCCAddr As Variant, _
                                 ByVal vntBCCName As Variant, _
                                 ByVal vntBCCAddr As Variant, _
                                 ByVal swOwnerBCC As Boolean, _
                                 ByVal strSubj As String, _
                                 ByVal strBody As String, _
                                 Optional ByVal vntAttachFile As Variant = "") As Boolean
    '===============================================================================================
    Dim objFso As FileSystemObject                                  ' FileSystemObject
    Dim strSV_Name As String                                        ' Domain/SMTP:Port:TimeOut
    Dim strMailFrom As String                                       ' 差出人登録
    Dim strMailTo As String                                         ' 宛先登録
    Dim strAttachFile As String                                     ' 添付ファイル
    Dim blnSuccess As Boolean                                       ' 処理成否
    Dim strRet As String                                            ' 処理結果
    SendMailByBASP21 = False
    g_strErrMSG = ""
    Set objFso = New FileSystemObject
    '-----------------------------------------------------------------------------------------------
    ' BSMTP.dllの存在確認
    blnSuccess = FP_CheckExistsFile(objFso, objFso.BuildPath(FP_GetSystemDirectory, "BSMTP.dll"))
    Set objFso = Nothing
    ' 存在しなければ終了
    If Not blnSuccess Then Exit Function
    '-----------------------------------------------------------------------------------------------
    ' ドメイン・差出人チェック
    If Not FP_CheckDomainAndFrom(strSV_Name, strMailFrom) Then Exit Function
    '-----------------------------------------------------------------------------------------------
    ' 宛先、CC、BCCチェック及び編集(TOに接続)
    If Not FP_CheckToAndCcBcc(vntToName, _
                              vntToAddr, _
                              vntCCName, _
                              vntCCAddr, _
                              vntBCCName, _
                              vntBCCAddr, _
                              swOwnerBCC, _
                              strMailTo) Then Exit Function
    '-----------------------------------------------------------------------------------------------
    ' 添付ファイルチェック
    If Not FP_CheckAttachFile(vntAttachFile, strAttachFile) Then Exit Function
    '-----------------------------------------------------------------------------------------------
    On Error Resume Next
    ' SendMailメソッドの呼び出し
    strRet = SendMail(strSV_Name, strMailTo, strMailFrom, strSubj, strBody, strAttachFile)
    ' エラーか
    If Err.Number <> 0 Then
        g_strErrMSG = "メール送信に失敗しました。" & vbCrLf & Err.Description
    ElseIf strRet <> "" Then
        g_strErrMSG = "サーバーに接続できないか、切断されました。(" & strRet & ")"
    End If
    On Error GoTo 0
    ' 処理結果を返す
    SendMailByBASP21 = g_strErrMSG = ""
End Function

'***************************************************************************************************
'* 処理名　：EditSubj
'* 機能　　：件名の編集(改行コード削除)
'---------------------------------------------------------------------------------------------------
'* 返り値　：件名(String)
'* 引数　　：Arg1 = セル上の件名(String)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2017年10月09日
'* 作成者　：井上　治
'* 更新日　：2017年10月09日
'* 更新者　：井上　治
'* 機能説明：改行コードを削除
'* 注意事項：
'***************************************************************************************************
Friend Function EditSubj(ByVal strSubj As String) As String
    '-----------------------------------------------------------------------------------------------
    strSubj = Replace(Trim(strSubj), vbCr, "")
    strSubj = Replace(Trim(strSubj), vbLf, "")
    EditSubj = strSubj
End Function

'***************************************************************************************************
'* 処理名　：EditBody
'* 機能　　：本文の編集(改行コード調整)
'---------------------------------------------------------------------------------------------------
'* 返り値　：本文(String)
'* 引数　　：Arg1 = セル上の本文(String)
'* 　　　　　Arg2 = セル上の署名(String)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2017年10月09日
'* 作成者　：井上　治
'* 更新日　：2017年10月09日
'* 更新者　：井上　治
'* 機能説明：本文と署名の間に空行を挿入
'* 注意事項：
'***************************************************************************************************
Friend Function EditBody(ByVal strBody As String, _
                         ByVal strSign As String) As String
    '-----------------------------------------------------------------------------------------------
    Dim strBody2 As String                                          ' 編集後本文
    strBody2 = FP_EditBodySUB(strBody)
    ' 署名の有無を判定
    If strSign <> "" Then
        ' 本文の最後に改行(空行)を付加
        If Right(strBody2, 4) <> vbCrLf & vbCrLf Then
            strBody2 = strBody2 & vbCrLf
        End If
        EditBody = strBody2 & FP_EditBodySUB(strSign)
    Else
        EditBody = strBody2
    End If
End Function

'***************************************************************************************************
'   ■■■ サブ処理(Pirvate) ■■■
'***************************************************************************************************
'* 処理名　：FP_CheckDomainAndFrom
'* 機能　　：ドメイン・差出人チェック
'---------------------------------------------------------------------------------------------------
'* 返り値　：処理成否(Boolean)
'* 引数　　：Arg1 = ドメイン～タイムアウト(String)          ※Ref参照
'* 　　　　　Arg2 = 差出人(String)                          ※Ref参照
'---------------------------------------------------------------------------------------------------
'* 作成日　：2017年10月01日
'* 作成者　：井上　治
'* 更新日　：2017年10月03日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Private Function FP_CheckDomainAndFrom(ByRef strSV_Name As String, _
                                       ByRef strMailFrom As String) As Boolean
    '-----------------------------------------------------------------------------------------------
    FP_CheckDomainAndFrom = False
    ' SMTPチェック
    If g_strSMTP = "" Then
        g_strErrMSG = "「SMTPサーバ」が指定されていません。"
        Exit Function
    End If
    ' ドメイン/SMTP:ポート:タイムアウトを編集
    If g_strDomain <> "" Then
        strSV_Name = Trim(g_strDomain) & "/" & _
                     Trim(g_strSMTP) & ":" & _
                     CStr(g_intPort) & ":" & _
                     CStr(g_intTimeOut)
    Else
        strSV_Name = Trim(g_strSMTP) & ":" & _
                     CStr(g_intPort) & ":" & _
                     CStr(g_intTimeOut)
    End If
    '-----------------------------------------------------------------------------------------------
    ' 差出人チェック
    If g_strFromAddr = "" Then
        g_strErrMSG = "「差出人アドレス」が指定されていません。"
        Exit Function
    End If
    ' 差出人を編集
    strMailFrom = FP_JointMailAddress(g_strFromName, g_strFromAddr)
    FP_CheckDomainAndFrom = True
End Function

'***************************************************************************************************
'* 処理名　：FP_CheckToAndCcBcc
'* 機能　　：宛先、CC、BCCチェック及び編集
'---------------------------------------------------------------------------------------------------
'* 返り値　：処理成否(Boolean)
'* 引数　　：Arg1 = 宛先名(Variant)                         ※複数の場合は配列をセット
'* 　　　　　Arg2 = 宛先アドレス(Variant)                   ※複数の場合は配列をセット
'* 　　　　　Arg3 = CC名(Variant)                           ※複数の場合は配列をセット
'* 　　　　　Arg4 = CCアドレス(Variant)                     ※複数の場合は配列をセット
'* 　　　　　Arg5 = BCC名(Variant)                          ※複数の場合は配列をセット
'* 　　　　　Arg6 = BCCアドレス(Variant)                    ※複数の場合は配列をセット
'* 　　　　　Arg7 = 差出人BCC指定(Boolean)
'* 　　　　　Arg8 = 編集後の宛先(String)                    ※Ref参照
'---------------------------------------------------------------------------------------------------
'* 作成日　：2017年10月01日
'* 作成者　：井上　治
'* 更新日　：2017年10月01日
'* 更新者　：井上　治
'* 機能説明：編集後の宛先はCC、BCCをTabで挟んで宛先に接合する(BASP21仕様)
'* 注意事項：チェックは宛先ブランクのみ
'***************************************************************************************************
Private Function FP_CheckToAndCcBcc(ByVal vntToName As Variant, _
                                    ByVal vntToAddr As Variant, _
                                    ByVal vntCCName As Variant, _
                                    ByVal vntCCAddr As Variant, _
                                    ByVal vntBCCName As Variant, _
                                    ByVal vntBCCAddr As Variant, _
                                    ByVal swOwnerBCC As Boolean, _
                                    ByRef strMailTo As String) As Boolean
    '-----------------------------------------------------------------------------------------------
    Dim strMailCc As String                                         ' CC登録
    Dim strMailBcc As String                                        ' BCC登録
    FP_CheckToAndCcBcc = False
    ' 宛先、CC、BCC編集
    strMailTo = FP_JointMailAddress(vntToName, vntToAddr)
    strMailCc = FP_JointMailAddress(vntCCName, vntCCAddr)
    strMailBcc = FP_JointMailAddress(vntBCCName, vntBCCAddr)
    ' 宛先チェック
    If strMailTo = "" Then
        g_strErrMSG = "「宛先アドレス」が指定されていません。"
        Exit Function
    End If
    ' 差出人BCC追加指定
    If swOwnerBCC Then
        ' ブランクでなければTabを挟む
        If strMailBcc <> "" Then
            strMailBcc = strMailBcc & vbTab & FP_JointMailAddress(g_strFromName, g_strFromAddr)
        Else
            strMailBcc = FP_JointMailAddress(g_strFromName, g_strFromAddr)
        End If
    End If
    ' CCをTOに接合
    If strMailCc <> "" Then
        strMailTo = strMailTo & vbTab & "cc" & vbTab & strMailCc
    End If
    ' BCCをTOに接合
    If strMailBcc <> "" Then
        strMailTo = strMailTo & vbTab & "bcc" & vbTab & strMailBcc
    End If
    FP_CheckToAndCcBcc = True
End Function

'***************************************************************************************************
'* 処理名　：FP_CheckAttachFile
'* 機能　　：添付ファイルチェック
'---------------------------------------------------------------------------------------------------
'* 返り値　：処理成否(Boolean)
'* 引数　　：Arg1 = 添付ファイル名(Variant)                 ※複数の場合は配列をセット
'* 　　　　　Arg2 = 編集後添付ファイル名(String)            ※Ref参照
'---------------------------------------------------------------------------------------------------
'* 作成日　：2017年10月01日
'* 作成者　：井上　治
'* 更新日　：2017年10月01日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Private Function FP_CheckAttachFile(ByVal vntAttachFile As Variant, _
                                    ByRef strAttachFile As String) As Boolean
    '-----------------------------------------------------------------------------------------------
    Dim objFso As FileSystemObject                                  ' FileSystemObject
    FP_CheckAttachFile = False
    strAttachFile = ""
    Set objFso = New FileSystemObject
    ' 未使用判定
    If IsError(vntAttachFile) Then vntAttachFile = ""
    ' 複数ファイルか
    If IsArray(vntAttachFile) Then
        '-------------------------------------------------------------------------------------------
        ' 複数指定時
        Dim lngIx As Long                                           ' テーブルINDEX
        Dim strFile As String                                       ' ファイル名Work
        ' 先頭テーブルをセット
        strFile = Trim(vntAttachFile(lngIx))
        ' エラーは終了
        If Not FP_CheckExistsFile(objFso, strFile) Then
            Set objFso = Nothing
            Exit Function
        End If
        ' 先頭ファイル名を配置
        strAttachFile = strFile
        ' 次要素から開始
        lngIx = 1
        ' テーブルを巡回
        Do While lngIx <= UBound(vntAttachFile)
            strFile = Trim(vntAttachFile(lngIx))
            ' エラーは終了
            If Not FP_CheckExistsFile(objFso, strFile) Then
                Set objFso = Nothing
                Exit Function
            End If
            ' Tabを挟んで接合
            strAttachFile = strAttachFile & vbTab & strFile
            ' 次へ
            lngIx = lngIx + 1
        Loop
    ElseIf vntAttachFile <> "" Then
        strAttachFile = Trim(vntAttachFile)
        If Not FP_CheckExistsFile(objFso, strAttachFile) Then
            Set objFso = Nothing
            Exit Function
        End If
    End If
    Set objFso = Nothing
    FP_CheckAttachFile = True
End Function

'***************************************************************************************************
'   ■■■ 共通サブ処理(Pirvate) ■■■
'***************************************************************************************************
'* 処理名　：FP_JointMailAddress
'* 機能　　：名称＋アドレス接合
'---------------------------------------------------------------------------------------------------
'* 返り値　：接合後アドレス(String)
'* 引数　　：Arg1 = 名称(Variant)
'* 　　　　　Arg2 = アドレス(Variant)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2017年10月01日
'* 作成者　：井上　治
'* 更新日　：2017年10月01日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：複数指定時は2件目以降をTabで区切る
'***************************************************************************************************
Private Function FP_JointMailAddress(ByVal vntName As Variant, _
                                     ByVal vntEmail As Variant) As String
    '-----------------------------------------------------------------------------------------------
    Dim strName As String                                           ' 名称
    Dim strEmail As String                                          ' アドレス
    ' 未使用判定
    If IsError(vntName) Then vntName = ""
    If IsError(vntEmail) Then vntEmail = ""
    ' アドレスが配列(複数指定)か
    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)
        ' 名称も配列(複数指定)か
        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件目以降はTabで区切る
            If strAddr <> "" Then
                strAddr = strAddr & vbTab
            End If
            ' アドレスのみか
            If strName = "" Then
                strAddr = strAddr & strEmail
            Else
                strAddr = strAddr & strName & "<" & strEmail & ">"
            End If
            ' 次へ
            lngIx = lngIx + 1
        Loop
        FP_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
            FP_JointMailAddress = strEmail
        Else
            FP_JointMailAddress = strName & "<" & strEmail & ">"
        End If
    End If
End Function

'***************************************************************************************************
'* 処理名　：FP_CheckExistsFile
'* 機能　　：ファイル存在チェック
'---------------------------------------------------------------------------------------------------
'* 返り値　：処理成否(Boolean)
'* 引数　　：Arg1 = FileSystemObject(Object)
'* 　　　　　Arg2 = フルパスファイル名(String)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2017年10月01日
'* 作成者　：井上　治
'* 更新日　：2017年10月01日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Private Function FP_CheckExistsFile(ByRef objFso As FileSystemObject, _
                                    ByVal strFilename As String) As Boolean
    '-----------------------------------------------------------------------------------------------
    Dim blnSuccess As Boolean                                       ' 処理成否
    ' ブランクは無視(正常扱い)
    If strFilename = "" Then
        FP_CheckExistsFile = True
        Exit Function
    End If
    blnSuccess = objFso.FileExists(strFilename)
    ' 不成功はメッセージを編集
    If Not blnSuccess Then
        g_strErrMSG = "指定のファイルが実在しません。" & vbCrLf & strFilename
    End If
    FP_CheckExistsFile = blnSuccess
End Function

'***************************************************************************************************
'* 処理名　：FP_GetSystemDirectory
'* 機能　　：システムフォルダの取得
'---------------------------------------------------------------------------------------------------
'* 返り値　：システムフォルダパス(String)
'* 引数　　：(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2017年10月01日
'* 作成者　：井上　治
'* 更新日　：2017年10月01日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Private Function FP_GetSystemDirectory() As String
    '-----------------------------------------------------------------------------------------------
    Dim strBuffer As String                                         ' 処理バッファ
    ' Bufferを確保
    strBuffer = String(g_cnsMaxPath, Chr(0))
    ' SYSTEMディレクトリ名取得
    Call GetSystemDirectory(strBuffer, g_cnsMaxPath)
    ' Null文字の手前までを有効として表示
    FP_GetSystemDirectory = Left(strBuffer, InStr(1, strBuffer, Chr(0)) - 1)
End Function

'***************************************************************************************************
'* 処理名　：FP_EditBodySUB
'* 機能　　：本文の編集サブ処理
'---------------------------------------------------------------------------------------------------
'* 返り値　：編集後文字列(String)
'* 引数　　：Arg1 = 編集前文字列(String)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2017年10月09日
'* 作成者　：井上　治
'* 更新日　：2017年10月09日
'* 更新者　：井上　治
'* 機能説明：LF改行をCRLF改行に置き換える
'* 注意事項：
'***************************************************************************************************
Private Function FP_EditBodySUB(ByVal strText As String) As String
    '-----------------------------------------------------------------------------------------------
    Dim strText2 As String                                          ' 文字列編集Work
    ' ブランクの時は何もしない
    If strText = "" Then
        FP_EditBodySUB = ""
        Exit Function
    End If
    ' 元々のCRLF改行を一旦LF改行に変更
    strText2 = Replace(Trim(strText), vbCrLf, vbLf)
    ' LF改行をCRLF改行に変更
    strText2 = Replace(strText2, vbLf, vbCrLf)
    ' 最後に改行を付加
    If Right(strText2, 2) <> vbCrLf Then
        strText2 = strText2 & vbCrLf
    End If
    FP_EditBodySUB = strText2
End Function

'***************************************************************************************************
'   ■■■ プロパティ ■■■
'***************************************************************************************************
'   ドメインアドレス(String)
'---------------------------------------------------------------------------------------------------
Friend Property Let prpDomain(ByVal Value As String)
    '-----------------------------------------------------------------------------------------------
    g_strDomain = Value
End Property

'===================================================================================================
'   SMTPサーバアドレス(String)
'---------------------------------------------------------------------------------------------------
Friend Property Let prpSMTP(ByVal Value As String)
    '-----------------------------------------------------------------------------------------------
    g_strSMTP = Value
End Property

'===================================================================================================
'   ポート№(Integer)
'---------------------------------------------------------------------------------------------------
Friend Property Let prpPort(ByVal Value As Integer)
    '-----------------------------------------------------------------------------------------------
    g_intPort = Value
End Property

'===================================================================================================
'   タイムアウト値(Integer)
'---------------------------------------------------------------------------------------------------
Friend Property Let prpTimeOut(ByVal Value As Integer)
    '-----------------------------------------------------------------------------------------------
    g_intTimeOut = Value
End Property

'===================================================================================================
'   差出人名(String)
'---------------------------------------------------------------------------------------------------
Friend Property Let prpFromName(ByVal Value As String)
    '-----------------------------------------------------------------------------------------------
    g_strFromName = Value
End Property

'===================================================================================================
'   差出人アドレス(String)
'---------------------------------------------------------------------------------------------------
Friend Property Let prpFromAddr(ByVal Value As String)
    '-----------------------------------------------------------------------------------------------
    g_strFromAddr = Value
End Property

'===================================================================================================
'   エラーメッセージ(String)
'---------------------------------------------------------------------------------------------------
Friend Property Get prpErrMSG() As String
    prpErrMSG = g_strErrMSG
End Property

'------------------------------------------<< End of Source >>--------------------------------------

利用するコンポーネントは「BASP21.dll」本体ではなく、同梱されているメール送信コンポーネント「BSMTP.dll」です。「BASP21.dll」の「SendMail」メソッドでも結局は「BSMTP.dll」が働くようで、しかも「BSMTP.dll」は単独でダウンロードもできるので直接利用しています。

プロパティ項目の説明
連続して送信を繰り返すような処理も想定して、初期設定で設定すれば以降変更がないと思われるサーバ関連と差出人関連の項目はプロパティで設定するようにしてあります。

項目	フィールドID	タイプ	R/W	内　容
ドメインアドレス	prpDomain	文字列	WriteOnly	ドメインアドレスのURLを指定します。(※省略可)
SMTPサーバアドレス	prpSMTP	文字列	WriteOnly	SMTPサーバのURL又はIPアドレスを指定します。(※必須)
ポート№	prpPort	整数	WriteOnly	メール送信サーバのポート番号を指定します。省略すると「25」になります。本項目はプロバイダか社内のネットワーク管理者の指示に従う項目です。
タイムアウト値	prpTimeOut	整数	WriteOnly	メール送信サーバが無応答と判断するまでの秒数です。省略すると「60」になります。
差出人名	prpFromName	文字列	WriteOnly	差出人の名称です。(※省略可)
差出人アドレス	prpFromAddr	文字列	WriteOnly	差出人のメールアドレスです。(※必須)
エラーメッセージ	prpErrMSG	文字列	ReadOnly	メール送信失敗時に本クラス側が編集したエラーメッセージを取り出すためのプロパティです。

メール送信メソッド(SendMailByCDO)の引数の説明

SEQ	項目	タイプ	内　容
1	宛先名	文字列	宛先の表示名称 ※複数指定時は配列でセットする。
2	宛先アドレス	文字列	宛先のメールアドレス ※複数指定時は配列でセットする。
3	CC名	文字列	CCの表示名称 ※複数指定時は配列でセットする。
4	CCアドレス	文字列	CCのメールアドレス ※複数指定時は配列でセットする。
5	BCC名	文字列	BCCの表示名称 ※複数指定時は配列でセットする。
6	BCCアドレス	文字列	BCCのメールアドレス ※複数指定時は配列でセットする。
7	差出人BCC指定	Boolean	Trueを指定すると差出人をBCCに設定します。
8	件名	文字列	メールの件名を指定します。
9	本文	文字列	メールの本文を指定します。
10	添付ファイル名	文字列	添付ファイル名をフルパスで指定します。 ※複数指定時は配列でセットする。

本機能のご利用上のご注意

・まず、不特定多数を宛先とする広告メールなどでのご利用はお断わりします。
・送信認証サーバでの送信についての質問は当方では対応できません。利用者側のネットワーク管理者にお問合せ下さい。
・携帯電話へのメール送信も可能ですが、宛先を多数設定したり連続して送信するとキャリアの中継サーバに拒否されるようです。

←SendMailByBASP21.zip
(76KB)

メール送信 (BASP21利用)

マクロ上でデータファイルを添付してメールを自動送信するプロシージャをモジュールでインポートして利用できるものを用意しました。