マクロ上でメールを自動送信するプロシージャで、Windows2000以降なら追加インストールの要らない方法を用意しました。
「CDO」はWindowsに標準搭載されているコンポーネントです。
前ページの「メール送信（BASP21利用)」はフリーソフトではありますが、「BASP21」自体をインストールさせる必要がありました。
ここで紹介する「CDO」はWindows2000以降なら標準で搭載されているコンポーネントなので追加インストールさせる必要がありません。
但し、「CDO」はメール送信専用となるとお考え下さい。
できる限り汎用性を高められるようにクラスモジュールとしてあります。
但し、「CDO」はメール送信専用となるとお考え下さい。
できる限り汎用性を高められるようにクラスモジュールとしてあります。
送信認証を要求するメールサーバについて
本来、インターネットメールの送信では「ユーザー」「パスワード」といった認証は行ないません。
これは原理が「郵便」と同じであって「誰でも投函できる」という仕組みに倣ったものなのだそうです。
差出人を偽らないのは利用上の「ルール」であって、メールの仕組み上ではブロックされてはいなかったのです。
ですが、これがスパムメールの温床になっているわけですから、送信サーバを提供する側が「送信認証」の仕組みを取り入れてくるようになってきています。 「送信認証」の仕組みは種類がいろいろあるようで、さらに「暗号化」を組み合わせることも多いようです。
私は「その方面」の専門家ではないので解説はできませんが、「CDO」でできる設定をいろいろ試してみて、 自分の環境(個人の契約プロバイダ環境)での送信はできるようになりましたから、送信可能になったコードの項目は公開しています。 なお、これはご自分でコードを書いて試すことができる方でないとご利用いただけません。
このページは「組み込み用モジュール」としての提供ができるようにということですから、送信認証や暗号化項目、さらに返信先(ReplyTo)の設定も網羅させてあります。
ですが、これがスパムメールの温床になっているわけですから、送信サーバを提供する側が「送信認証」の仕組みを取り入れてくるようになってきています。 「送信認証」の仕組みは種類がいろいろあるようで、さらに「暗号化」を組み合わせることも多いようです。
私は「その方面」の専門家ではないので解説はできませんが、「CDO」でできる設定をいろいろ試してみて、 自分の環境(個人の契約プロバイダ環境)での送信はできるようになりましたから、送信可能になったコードの項目は公開しています。 なお、これはご自分でコードを書いて試すことができる方でないとご利用いただけません。
このページは「組み込み用モジュール」としての提供ができるようにということですから、送信認証や暗号化項目、さらに返信先(ReplyTo)の設定も網羅させてあります。
- では、その「CDO」を使って送信することにします。
-
まずは、簡単なサンプルで説明してみましょう。
(画像をクリックすると、このサンプルがダウンロードできます)
通常の送信認証がないメール送信サーバでの運用であれば、SMTPサーバと差出人名、メールアドレスを変更し、件名、メール文面・署名、必要に応じて添付ファイルを指定して下さい。
I列から右に宛先、CC、BCCの項目があります。
送信認証があるメール送信サーバの場合は、暗号化の有無によりポート番号の変更が必要で、下の詳細情報の指定が必要となります。 用語は違うかも知れませんが、メールソフトでも同様の設定を行なっているはずです。
まずは、自分自身を宛先に指定するなどで動作の確認を行なって下さい。
メール送信を行なう指定項目の要素は全てこの「Sheet1」上の各セルにあり、送信機能を呼び出す「メール送信」ボタンも同様に「Sheet1」上にあります。
これらの情報をまとめて「CDOメール送信クラス」を呼び出すまではこの「Sheet1」のクラスモジュールに記述されています。
メール送信機能を実現するということからすると「メール送信」ボタン(CommandButton1_Click)の記述に着目していただければ良いでしょう。 実際のメール送信はこの下で紹介する「CDOメール送信クラス(clsSendMailByCDO1)」が行なうのですが、 その詳細は理解されなくてもプロパティ項目と「メール送信(SendMailByCDO)」の引数の理解があれば送信動作まで持っていくことができるはずです。'*************************************************************************************************** ' メール送信機能(CDO) Sheet1(Class) ' ' 作成者:井上治 URL:https://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!] '*************************************************************************************************** ' 変更日付 Rev 変更履歴内容----------------------------------------------------------------------> ' 04/11/06(1.0.0)新規作成 ' 17/10/09(2.0.0)クラス化移行､Excel2000以前の対応記述廃止、送信認証関連の追加 '*************************************************************************************************** Option Explicit '=================================================================================================== Private Const g_cnsTitle As String = "メール送信機能(CDO)" '*************************************************************************************************** ' ■■■ ワークシートイベント ■■■ '*************************************************************************************************** '* 処理名 ：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")) ' CC名 vntCCAddr = FP_GetCellsValue(Range("$L$3:$L$1048576")) ' CCアドレス vntBCCName = FP_GetCellsValue(Range("$M$3:$M$1048576")) ' BCC名 vntBCCAddr = FP_GetCellsValue(Range("$N$3:$N$1048576")) ' BCCアドレス swOwnerBCC = Cells(30, 2).Value = "送信者をBCCに加える" ' 差出人BCC指定 vntAttachFile = FP_GetCellsValue(Range("$B$25:$H$29"), 30) ' 添付ファイル名 '----------------------------------------------------------------------------------------------- ' CDOメール送信クラス(clsSendMailByCDO1)の呼び出し With New clsSendMailByCDO1 ' プロパティ項目(連続使用の場合に毎回セットしなくても良い項目) .prpSMTP = Trim(Cells(3, 2).Value) ' SMTPサーバ .prpPort = Cells(4, 2).Value ' ポート№ .prpTimeOut = Cells(5, 2).Value ' タイムアウト .prpFromName = Trim(Cells(6, 2).Value) ' 差出人 .prpFromAddr = Trim(Cells(7, 2).Value) ' 〃アドレス .prpLanguageCode = Trim(Cells(34, 2).Value) ' 文字コード .prpReplyToName = Trim(Cells(39, 2).Value) ' 返信先名 .prpReplyToAddr = Trim(Cells(40, 2).Value) ' 返信先アドレス ' 件名・本文の編集(改行調整) strSubj = .EditSubj(Cells(8, 2).Value) ' 件名 strBody = .EditBody(Cells(9, 2).Value, Cells(20, 2).Value) ' 本文 ' 送信認証 If Trim(Cells(35, 2).Value) = "あり" Then .prpAuthenticate = 1 ' 認証指定(0=無し、1=有り) .prpUseSSL = Trim(Cells(36, 2).Value) = "あり" ' SSL使用 .prpSendUserName = Trim(Cells(37, 2).Value) ' 認証ユーザーID .prpSendPassword = Trim(Cells(38, 2).Value) ' 認証パスワード Else .prpAuthenticate = 0 .prpUseSSL = False .prpSendUserName = "" .prpSendPassword = "" End If ' メール送信メソッド If Not .SendMailByCDO(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月09日 '* 更新者 ：井上 治 '* 機能説明： '* 注意事項： '*************************************************************************************************** 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$25:$H$29").ClearContents lngRow = 24 ' 今回ドラッグされたファイルを登録 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月09日 '* 作成者 ：井上 治 '* 更新日 ：2017年10月09日 '* 更新者 ：井上 治 '* 機能説明：単一行の場合は文字列、複数行の場合は配列を返す '* 注意事項： '*************************************************************************************************** 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 >>--------------------------------------
このサンプルではプロパティと送信メソッドの引数は全項目がシート上にあるので全てを記述しており複雑に見えますが、 省略できる既定値や認証関連なども除外できて、CC、BCCを除外してしまえば10行程度で済んでしまうものです。
今回は「Sheet1」上で宛先、CC、BCCが名称とメールアドレスが別列で複数行登録できるようになっています。 1件であればそれぞれの引数項目に文字列として設定すれば良いのですが、複数件の場合は文字列配列で引数に設定する必要があります。 引数を受け取った「CDOメール送信クラス(clsSendMailByCDO1)」側が配列指定かどうかで件数を判断するようになっています。
このため、この引数セット値の編集を行なう関数としてサブ処理に「セル範囲の値の受け取り(FP_GetCellsValue)」を用意したわけです。
このサンプルは「単発送信」なので指定項目がプロパティ経由とメソッドの引数に別れている意味がありませんが、繰り返し送信動作を行なうプログラムでの利用を考慮しています。 送信サーバ設定及び差出人情報はクラス初期化直後に1回だけ登録すれば済むようにプロパティとしており、 宛先、CC、BCC、件名、本文、添付ファイルは送信ごとに書き換わるだろうということで送信メソッドの引数にしてあるわけです。
次の「連続送信」と比べていただくと利用方法の違いが判ると思います。
なお、「添付ファイルの参照登録」の機能も本ワークブックに持ち込んでありますが、メール送信の主機能の説明から外れるのでコードの紹介はしておりません。 関心がある方はダウンロードさせたプロジェクト内部をご覧下さい。
- 連続送信についても試してみて下さい。
-
本件でいただく質問メールには、シート上のリストに従って順次メール送信を行なうご希望が多いようです。
一応、そのようなサンプルも用意してみました。 ここでは同一の送信内容について1件のメール送信に対して宛先を複数登録して送信するというのではなく、 シートに登録してあるリストに対して、1行を1件のメールで送信することにします。
送信サーバ設定や差出人情報等は「サーバ・差出人」シートにまとめました。
このように、1宛先の情報を1行としてシート上に登録させておき、この内容を順次一括して送信させようとするものです。
ここでは、シート上の登録内容に対するチェックは特に行なっていません。「順次一括送信」といった場合のコードがどのようになるかを理解していただくためにコードはできるだけ単純化したつもりです。
このようなコードになりました。
このコードは、あくまで「サンプル」ということですから、参考までとして下さい。'*************************************************************************************************** ' メール送信機能：連続送信サンプル(CDO) Sheet2(Class) ' ' 作成者:井上治 URL:https://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!] '*************************************************************************************************** ' 変更日付 Rev 変更履歴内容----------------------------------------------------------------------> ' 07/10/07(1.0.0)新規作成 ' 17/10/09(2.0.0)クラス化移行､Excel2000以前の対応記述削除､送信認証対応機能を追加 ' 19/10/28(2.1.0)Declare記述の変更(64ビット版Excel対応) '*************************************************************************************************** Option Explicit '=================================================================================================== ' ■スリープ #If VBA7 Then Private Declare PtrSafe Sub Sleep Lib "KERNEL32.dll" (ByVal dwMilliseconds As Long) #Else Private Declare Sub Sleep Lib "KERNEL32.dll" (ByVal dwMilliseconds As Long) #End If '*************************************************************************************************** ' ■■■ ワークシートイベント ■■■ '*************************************************************************************************** '* 処理名 ：CommandButton1_Click '* 機能 ：｢送信開始｣ボタンクリックイベント '--------------------------------------------------------------------------------------------------- '* 返り値 ：(なし) '* 引数 ：(なし) '--------------------------------------------------------------------------------------------------- '* 作成日 ：2007年10月07日 '* 作成者 ：井上 治 '* 更新日 ：2017年10月09日 '* 更新者 ：井上 治 '* 機能説明： '* 注意事項： '*************************************************************************************************** Private Sub CommandButton1_Click() '----------------------------------------------------------------------------------------------- Dim objSH1 As Worksheet ' サーバ・差出人シート Dim objSH2 As Worksheet ' 発信管理表シート Dim objSendMail As clsSendMailByCDO1 ' CDOメール送信クラス Dim lngRow As Long ' 行INDEX Dim lngRowMax As Long ' 行INDEX上限 Dim lngInterval As Long ' 送信間隔(ミリ秒) Dim strErrMSG As String ' エラーメッセージ Set objSH1 = ThisWorkbook.Worksheets("サーバ・差出人") Set objSH2 = ThisWorkbook.Worksheets("発信管理表") '----------------------------------------------------------------------------------------------- ' 送信確認 If MsgBox("メールを送信します。" & vbCr & _ "宛先等は正しいですか？", vbYesNo) <> vbYes Then Exit Sub '----------------------------------------------------------------------------------------------- ' CDOメール送信クラス(clsSendMailByCDO1)の初期化 Set objSendMail = New clsSendMailByCDO1 '----------------------------------------------------------------------------------------------- ' プロパティ項目のセット(サーバ・差出人シートより) With objSendMail .prpSMTP = Trim(objSH1.Cells(1, 2).Value) ' SMTPサーバ .prpPort = objSH1.Cells(2, 2).Value ' ポート番号 .prpTimeOut = objSH1.Cells(3, 2).Value ' タイムアウト .prpFromName = Trim(objSH1.Cells(5, 2).Value) ' 差出人名 .prpFromAddr = Trim(objSH1.Cells(6, 2).Value) ' 差出人アドレス .prpReplyToName = Trim(objSH1.Cells(7, 2).Value) ' 返信先名 .prpReplyToAddr = Trim(objSH1.Cells(8, 2).Value) ' 返信先アドレス .prpLanguageCode = Trim(objSH1.Cells(9, 2).Value) ' 文字コード .prpAuthenticate = IIf(objSH1.Cells(10, 2).Value = "あり", 1, 0) ' 送信認証 .prpUseSSL = Trim(objSH1.Cells(11, 2).Value) = "あり" ' SSL指定 .prpSendUserName = Trim(objSH1.Cells(12, 2).Value) ' アカウント .prpSendPassword = Trim(objSH1.Cells(13, 2).Value) ' パスワード End With lngInterval = objSH1.Cells(4, 2).Value * 1000 ' 送信間隔(ミリ秒) '----------------------------------------------------------------------------------------------- ' 発信管理表 With objSH2 ' オートフィルタ解除 If .FilterMode Then .ShowAllData ' 最終行取得 lngRowMax = .Range("$B$" & .Rows.Count).End(xlUp).Row lngRow = 2 ' 最終行まで繰り返す Do While lngRow <= lngRowMax ' 2件目からは指定秒数ウェイト If lngRow > 2 Then Sleep lngInterval End If ' ステータスバー表示 Application.StatusBar = .Cells(lngRow, 1).Value & " 送信中．．．．" ' メール送信(CDO) ※差出人をBCCにする時はFalseをTrueに変更して下さい If Not objSendMail.SendMailByCDO(Trim(.Cells(lngRow, 1).Value), _ Trim(.Cells(lngRow, 2).Value), _ "", _ "", _ "", _ "", _ False, _ objSendMail.EditSubj(.Cells(lngRow, 3).Value), _ objSendMail.EditBody(.Cells(lngRow, 4).Value, _ objSH1.Cells(14, 2).Value), _ Trim(.Cells(lngRow, 5).Value)) Then ' 送信失敗⇒メッセージを表示 MsgBox objSendMail.prpErrMSG, vbCritical ' 送信中止 Exit Do End If ' 次の行へ lngRow = lngRow + 1 Loop End With Application.StatusBar = False Set objSendMail = Nothing End Sub '------------------------------------------<< End of Source >>--------------------------------------
このサンプルでは「CDOメール送信クラス(clsSendMailByCDO1)」は 先頭の方で「objSendMail」という変数に初期化して確保させており、 以降はこの変数に対してプロパティをセットしたり、送信メソッド(SendMailByCDO)をループ内で呼び出したりという動作になっています。
- 送信の「中核部分」の「CDOメール送信クラス(clsSendMailByCDO1)」です。
-
ここからのコードは、一般的な利用方法では改変を加える必要はないと思います。モジュールをインポートさせて参照設定を行ない、
呼び出す記述を用意すればメール送信は実現できるようにと配慮してあります。
'*************************************************************************************************** ' メール送信機能(CDO) clsSendMailByCDO1(Class) ' ' 作成者:井上治 URL:https://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!] '*************************************************************************************************** ' [参照設定] ' ・Microsoft CDO for Windows 2000 Library ' ・Microsoft Scripting Runtime '*************************************************************************************************** ' 変更日付 Rev 変更履歴内容----------------------------------------------------------------------> ' 06/07/01(1.0.0)新規作成 ' 17/10/09(2.0.0)クラス化移行､Excel2000以前の対応記述削除､送信認証対応機能、件名・本文編集を追加 ' 18/11/04(2.0.1)送信認証有無に関係なくユーザー､パスワード指定が必要となってしまう件を修正 '*************************************************************************************************** Option Explicit '=================================================================================================== Private Const g_cnsTitle As String = "メール送信機能(CDO)" ' フォルダパス文字数上限 Private Const g_cnsMaxPath As Long = 260 ' カンマ Private Const g_cnsCom As String = "," '--------------------------------------------------------------------------------------------------- ' プロパティから引き渡される変数 Private g_strSMTP As String ' SMTPサーバアドレス Private g_intPort As Integer ' ポート№ Private g_intTimeOut As Integer ' タイムアウト値 Private g_strLanguageCode As String ' 文字コード指定 Private g_strFromName As String ' 差出人名 Private g_strFromAddr As String ' 差出人アドレス Private g_strReplyToName As String ' 返信先名 Private g_strReplyToAddr As String ' 返信先アドレス Private g_strErrMSG As String ' エラーメッセージ ' 送信認証関連 Private g_intAuthenticate As Integer ' 認証指定(0=無し、1=有り) Private g_blnUseSSL As Boolean ' SSL使用 Private g_strSendUserName As String ' 認証ユーザーID Private g_strSendPassword As String ' 認証パスワード '*************************************************************************************************** ' ■■■ クラス初期化 ■■■ '*************************************************************************************************** '* 処理名 ：Class_Initialize '* 機能 ：クラス初期化 '--------------------------------------------------------------------------------------------------- '* 返り値 ：(なし) '* 引数 ：(なし) '--------------------------------------------------------------------------------------------------- '* 作成日 ：2017年10月09日 '* 作成者 ：井上 治 '* 更新日 ：2017年10月09日 '* 更新者 ：井上 治 '* 機能説明： '* 注意事項： '*************************************************************************************************** Private Sub Class_Initialize() '----------------------------------------------------------------------------------------------- ' ポート№､タイムアウト値等の初期値投入(非認証時デフォルト) g_intPort = 25 g_intTimeOut = 60 g_strLanguageCode = "iso-2022-jp" g_intAuthenticate = 0 g_blnUseSSL = False End Sub '*************************************************************************************************** ' ■■■ 外部からの呼び出しプロシージャ(Friend) ■■■ '*************************************************************************************************** '* 処理名 ：SendMailByCDO '* 機能 ：メール送信(CDO) '--------------------------------------------------------------------------------------------------- '* 返り値 ：処理成否(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) '--------------------------------------------------------------------------------------------------- '* 作成日 ：2006年07月01日 '* 作成者 ：井上 治 '* 更新日 ：2017年10月09日 '* 更新者 ：井上 治 '* 機能説明： '* 注意事項： '*************************************************************************************************** Friend Function SendMailByCDO(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 objCDO As CDO.Message ' CDO Dim lngIx As Long ' テーブルINDEX Dim strMailFrom As String ' 差出人登録 Dim strMailTo As String ' 宛先登録 Dim strMailCc As String ' CC登録 Dim strMailBcc As String ' BCC登録 Dim strMailReplyTo As String ' ReplyTo登録 SendMailByCDO = False g_strErrMSG = "" '----------------------------------------------------------------------------------------------- ' プロパティ項目チェック If Not FP_CheckPropertyItem(strMailFrom, strMailReplyTo) Then Exit Function '----------------------------------------------------------------------------------------------- ' 宛先、CC、BCCチェック及び編集 If Not FP_CheckToAndCcBcc(vntToName, _ vntToAddr, _ vntCCName, _ vntCCAddr, _ vntBCCName, _ vntBCCAddr, _ swOwnerBCC, _ strMailTo, _ strMailCc, _ strMailBcc) Then Exit Function '----------------------------------------------------------------------------------------------- ' 本文の最終改行を確認 '----------------------------------------------------------------------------------------------- ' 添付ファイルチェック If Not FP_CheckAttachFile(vntAttachFile) Then Exit Function '----------------------------------------------------------------------------------------------- On Error Resume Next Set objCDO = New CDO.Message With objCDO With .Configuration.Fields ' 設定項目 .Item(cdoSendUsingMethod) = cdoSendUsingPort ' 外部SMTP指定 .Item(cdoSMTPServer) = g_strSMTP ' SMTPサーバ名 .Item(cdoSMTPServerPort) = g_intPort ' ポート№ .Item(cdoSMTPConnectionTimeout) = g_intTimeOut ' タイムアウト .Item(cdoLanguageCode) = g_strLanguageCode ' 文字セット指定 .Item(cdoSMTPAuthenticate) = g_intAuthenticate ' 認証指定 ' 認証指定あり If g_intAuthenticate = 1 Then .Item(cdoSendUserName) = g_strSendUserName ' 認証ユーザー .Item(cdoSendPassword) = g_strSendPassword ' 認証パスワード .Item(cdoSMTPUseSSL) = g_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 If strMailReplyTo <> "" Then .ReplyTo = strMailReplyTo ' ReplyTo .Subject = strSubj ' 件名 .TextBody = strBody ' 本文 .TextBodyPart.Charset = g_strLanguageCode ' 文字セット指定(本文) ' 添付ファイルの登録(複数対応) If IsArray(vntAttachFile) Then ' 配列処理 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 ' 処理結果を返す SendMailByCDO = 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_CheckPropertyItem '* 機能 ：プロパティ項目チェック '--------------------------------------------------------------------------------------------------- '* 返り値 ：処理成否(Boolean) '* 引数 ：Arg1 = 編集後の差出人(String) ※Ref参照 '* Arg2 = 編集後のReplyTo(String) ※Ref参照 '--------------------------------------------------------------------------------------------------- '* 作成日 ：2017年10月09日 '* 作成者 ：井上 治 '* 更新日 ：2018年11月04日 '* 更新者 ：井上 治 '* 機能説明： '* 注意事項： '*************************************************************************************************** Private Function FP_CheckPropertyItem(ByRef strMailFrom As String, _ ByRef strMailReplyTo As String) As Boolean '----------------------------------------------------------------------------------------------- FP_CheckPropertyItem = False ' SMTPチェック If g_strSMTP = "" Then g_strErrMSG = "「SMTPサーバ」が指定されていません。" Exit Function End If '----------------------------------------------------------------------------------------------- ' 差出人チェック If g_strFromAddr = "" Then g_strErrMSG = "「差出人アドレス」が指定されていません。" Exit Function End If ' 差出人を編集 strMailFrom = FP_JointMailAddress(g_strFromName, g_strFromAddr) '----------------------------------------------------------------------------------------------- ' 返信先チェック If g_strReplyToName <> "" And g_strReplyToAddr = "" Then g_strErrMSG = "「返信先アドレス」が指定されていません。" Exit Function End If ' 返信先を編集 strMailReplyTo = FP_JointMailAddress(g_strReplyToName, g_strReplyToAddr) '----------------------------------------------------------------------------------------------- ' 文字コードチェック If g_strLanguageCode = "" Then g_strErrMSG = "「文字コード(詳細情報)」が指定されていません。" Exit Function End If '----------------------------------------------------------------------------------------------- ' 送信認証関連チェック If ((g_intAuthenticate <> 0) And (g_intAuthenticate <> 1)) Then g_strErrMSG = "「送信認証(詳細情報)」が指定されていません。" Exit Function ElseIf g_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 FP_CheckPropertyItem = 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参照 '* Arg9 = 編集後のCC(String) ※Ref参照 '* Arg10= 編集後のBCC(String) ※Ref参照 '--------------------------------------------------------------------------------------------------- '* 作成日 ：2017年10月09日 '* 作成者 ：井上 治 '* 更新日 ：2017年10月09日 '* 更新者 ：井上 治 '* 機能説明：編集後の宛先、CC、BCCは複数の時はカンマで区切る '* 注意事項：チェックは宛先ブランクのみ '*************************************************************************************************** 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, _ ByRef strMailCc As String, _ ByRef strMailBcc As String) As Boolean '----------------------------------------------------------------------------------------------- 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 ' ブランクでなければカンマを挟む If strMailBcc <> "" Then strMailBcc = strMailBcc & g_cnsCom & FP_JointMailAddress(g_strFromName, g_strFromAddr) Else strMailBcc = FP_JointMailAddress(g_strFromName, g_strFromAddr) End If End If FP_CheckToAndCcBcc = True End Function '*************************************************************************************************** '* 処理名 ：FP_CheckAttachFile '* 機能 ：添付ファイルチェック '--------------------------------------------------------------------------------------------------- '* 返り値 ：処理成否(Boolean) '* 引数 ：Arg1 = 添付ファイル名(Variant) ※複数の場合は配列をセット '--------------------------------------------------------------------------------------------------- '* 作成日 ：2017年10月09日 '* 作成者 ：井上 治 '* 更新日 ：2017年10月09日 '* 更新者 ：井上 治 '* 機能説明： '* 注意事項： '*************************************************************************************************** Private Function FP_CheckAttachFile(ByRef vntAttachFile As Variant) As Boolean '----------------------------------------------------------------------------------------------- Dim objFso As FileSystemObject ' FileSystemObject FP_CheckAttachFile = False Set objFso = New FileSystemObject ' 未使用判定 If IsError(vntAttachFile) Then vntAttachFile = "" ' 複数ファイルか If IsArray(vntAttachFile) Then '------------------------------------------------------------------------------------------- ' 複数指定時 Dim lngIx As Long ' テーブルINDEX ' テーブルを巡回 Do While lngIx <= UBound(vntAttachFile) ' 存在確認 If Not FP_CheckExistsFile(objFso, Trim(vntAttachFile(lngIx))) Then Set objFso = Nothing Exit Function End If ' 次へ lngIx = lngIx + 1 Loop ElseIf vntAttachFile <> "" Then ' 存在確認 If Not FP_CheckExistsFile(objFso, Trim(vntAttachFile)) 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月09日 '* 作成者 ：井上 治 '* 更新日 ：2017年10月09日 '* 更新者 ：井上 治 '* 機能説明： '* 注意事項：複数指定時は2件目以降をカンマで区切る '*************************************************************************************************** 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件目以降はカンマで区切る If strAddr <> "" Then strAddr = strAddr & "," 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月09日 '* 作成者 ：井上 治 '* 更新日 ：2017年10月09日 '* 更新者 ：井上 治 '* 機能説明： '* 注意事項： '*************************************************************************************************** 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_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 '*************************************************************************************************** ' ■■■ プロパティ ■■■ '*************************************************************************************************** ' 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 prpLanguageCode(ByVal Value As String) '----------------------------------------------------------------------------------------------- g_strLanguageCode = 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 Let prpReplyToName(ByVal Value As String) g_strReplyToName = Value End Property '=================================================================================================== ' 返信先アドレス(String) '--------------------------------------------------------------------------------------------------- Friend Property Let prpReplyToAddr(ByVal Value As String) g_strReplyToAddr = Value End Property '=================================================================================================== ' 認証指定(0=無し、1=有り)(Integer) '--------------------------------------------------------------------------------------------------- Friend Property Let prpAuthenticate(ByVal Value As Integer) '----------------------------------------------------------------------------------------------- g_intAuthenticate = Value End Property '=================================================================================================== ' SSL使用(Boolean) '--------------------------------------------------------------------------------------------------- Friend Property Let prpUseSSL(ByVal Value As Boolean) '----------------------------------------------------------------------------------------------- g_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 '------------------------------------------<< End of Source >>--------------------------------------
プロパティ項目の説明
連続して送信を繰り返すような処理も想定して、初期設定で設定すれば以降変更がないと思われるサーバ関連と差出人関連の項目はプロパティで設定するようにしてあります。
項 目 フィールドID タイプ R/W 内 容 SMTPサーバ prpSMTP 文字列 WriteOnly SMTPサーバのURL又はIPアドレスを指定します。(※必須) ポート№ prpPort 整数 WriteOnly メール送信サーバのポート番号を指定します。省略すると「25」になります。送信認証を利用し暗号化を行なう場合は「465」にする場合が多いようですが、本項目はプロバイダか社内のネットワーク管理者の指示に従う項目です。 タイムアウト値 prpTimeOut 整数 WriteOnly メール送信サーバが無応答と判断するまでの秒数です。省略すると「60」になります。 文字コード指定 prpLanguageCode 文字列 WriteOnly メール自体の文字コードを指定します。省略すると「iso-2022-jp」になります。 差出人名 prpFromName 文字列 WriteOnly 差出人の名称です。(※省略可) 差出人アドレス prpFromAddr 文字列 WriteOnly 差出人のメールアドレスです。(※必須) 返信先名 prpReplyToName 文字列 WriteOnly 特定の返信先を指定する時の名称です。(※省略可) 返信先アドレス prpReplyToAdd 文字列 WriteOnly 特定の返信先を指定する時のメールアドレスです。(※省略可) 認証指定 prpAuthenticate 整数 WriteOnly 送信認証の有無を指定します。0が認証無し、1が認証有りです。 送信認証の有無はプロバイダか社内のネットワーク管理者の指示に従う項目です。 SSL使用 prpUseSSL Boolean WriteOnly メール送受信で暗号化を行なうかの指定です。本項目はプロバイダか社内のネットワーク管理者の指示に従う項目です。
※認証なしで暗号化のみ使用する設定はできません。認証ユーザーID prpSendUserName 文字列 WriteOnly 送信認証利用時のユーザーIDです。本項目はプロバイダか社内のネットワーク管理者の指定に従う項目です。 認証パスワード prpSendPassword 文字列 WriteOnly 送信認証利用時のユーザーIDに設定したパスワードです。本項目はプロバイダか社内のネットワーク管理者の指定もしくは利用者自身が登録したパスワードです。 エラーメッセージ 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 添付ファイル名 文字列 添付ファイル名をフルパスで指定します。
※複数指定時は配列でセットする。
- 本機能のご利用上のご注意
-
・まず、不特定多数を宛先とする広告メールなどでのご利用はお断わりします。
・送信認証サーバでの送信についての質問は当方では対応できません。利用者側のネットワーク管理者にお問合せ下さい。
・携帯電話へのメール送信も可能ですが、宛先を多数設定したり連続して送信するとキャリアの中継サーバに拒否されるようです。
 |
←SendMailByCDO1.zip (133KB) |
長文な本文の転記のご質問が多いです。
本文の転記にTextプロパティを使っていたのがいけなかったのですが、それに派生するように「複数セルに分散している本文は？」などの質問が多くなっています。
ここは「メール送信」に関する組み込みモジュールのサンプルだったので、そのモジュールを呼び出す方については重視していません。 ですが、このような状態なので「複数セルに分散している(SendMailByCDO1_2.xls)」「テキストボックスと使う(SendMailByCDO1_3.xls)」のサンプルも圧縮ファイルには含めておきました。
ここは「メール送信」に関する組み込みモジュールのサンプルだったので、そのモジュールを呼び出す方については重視していません。 ですが、このような状態なので「複数セルに分散している(SendMailByCDO1_2.xls)」「テキストボックスと使う(SendMailByCDO1_3.xls)」のサンプルも圧縮ファイルには含めておきました。