VBAでメール送信について紹介します。
自動でメール送信するツールを作ってみました。
今回はOutlookではなくフリーメール(YahooJapan)です。
実際に作ったファイルはこちらから無料でダウンロードできます。
使い方の説明はこちらからダウンロード可能です。
エクセルの名前の定義
エクセル自体にもセル名の定義をしているので、まずそこから説明しておきます。
意外とエクセルのVBAでは名前の定義を色々使えると良いことが多いです。
仕様と合わせて説明します。
仕様
①「送信元アカウント」を選択します。
リストは「アカウント」をもとに選べます。
下の画像で言うと、Gmail、Yahoo、YahooUSAがあるので3つから選べる状態です。
②送信ボタンをクリックすると「送信元アドレス」からとなりのシートを1つずつ読込んでメールを送信していきます。
名前の定義
メインシートの各名前は以下のようなルールで定義づけしています。
SMTPServer :[送信元アカウント] + [_smtpserver]
PortNumber :[送信元アカウント] + [_smtpserverport]
送信アカウント名 :[送信元アカウント] + [_sendusername]
パスワード :[送信元アカウント] + [_sendpassword]
送信元アドレス :[送信元アカウント] + [_From]
「メール送信」ボタンクリック後、後続の処理で「送信元アカウント」と文字連結をして送信を行います。
メール用の参照設定(CDO)
参照設定
ファイル用もフォルダ用もダイアログを開くに参照設定を必要です。
手順はコードエディターから「ツール(T)」→「参照設定(R)」と移動します。
その後、Microsoft CDO for Windows 2000 Libraryにチェックを付けておいてください。
CDOとはMicrosoft Collaboration Data Objectsのことだそうです。
CDO は、メッセージング機能を持つアプリケーションの作成を容易にするために、あるいは、既存のアプリケーションにメッセージング機能を追加するために設計されたものです。
microsoft.comより
Gmailの送信許可は不可になった
Gmailアカウントを使ってメール送信する場合は「安全性の低いアプリのアクセス」許可しておく必要があります。
設定は以下にアクセスすることで変更できます。
https://myaccount.google.com/lesssecureapps
2022年5月からGmailはユーザとパスワードでログインすることはできなくなりました。
YahooJapanアカウントを使ってメール送信する場合は特に設定は必要はないようです。
メール送信処理のコード
処理の流れは以下の順です。
①メインシートから送信元情報を取得
②となりのシートから送信メール内容を取得
③添付ファイルをメールオブジェクトに貼り付ける
④メールを送信する
⑤次のシートを同様に処理
コード
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 |
'============================== '目的 :シート分のメールを送信する '============================== Sub SendMail_Click() Dim MyDir As String '自分のファイルが存在するディレクトリ格納用 Dim i As Long 'ループ用変数 Dim j As Long 'ループ用変数 Dim SheetCnt As Long 'シート数を格納する変数 Dim SheetName As String 'シート名を格納する変数 Dim ToAddress As String 'Toアドレス用の変数 Dim CcAddress As String 'Ccアドレス用の変数 Dim BccAddress As String 'Bccアドレス用の変数 Dim FromAddress As String 'Fromアドレス用の変数 Dim cdoMsg As Object 'CDOメッセージオブジェクト用変数 Dim cdoConf As Object 'CDOコンフィグレーションオブジェクト用変数 Dim strMailBody As String 'メール本文用の変数 Dim strSubject As String '件名用の変数 Dim strSignature As String '署名用の変数 Dim strAttachmentPath As String '添付ファイルの格納用変数 Dim strAttachmentsPath() As String '添付ファイルの格納配列 Dim strSendAccount As String '送信するアカウント '固定値をセット(長いと見づらいため) Const cstUnderscore As String = "_" 'アンダーバー Const cstSendusing As String = "http://schemas.microsoft.com/cdo/configuration/sendusing" Const cstSmtpserver As String = "http://schemas.microsoft.com/cdo/configuration/smtpserver" Const cstSmtpserverport As String = "http://schemas.microsoft.com/cdo/configuration/smtpserverport" Const cstSendusername As String = "http://schemas.microsoft.com/cdo/configuration/sendusername" Const cstSendpassword As String = "http://schemas.microsoft.com/cdo/configuration/sendpassword" Const cstSmtpauthenticate As String = "http://schemas.microsoft.com/cdo/configuration/smtpauthenticate" Const cstSmtpusessl As String = "http://schemas.microsoft.com/cdo/configuration/smtpusessl" 'エラー時はErrCatchラベルへ On Error GoTo ErrCatch '-------シート枚数分ループ(2枚目のシートから)------- '自分の配置されているパスを取得 MyDir = ThisWorkbook.Path 'シート件数を取得 SheetCnt = ThisWorkbook.Sheets.Count For i = 2 To SheetCnt '----------送信元アカウント情報を設定(メインシートから取得)---------- 'CDOをオブジェクト作成 Set cdoMsg = CreateObject("CDO.Message") Set cdoConf = CreateObject("CDO.Configuration") cdoConf.Load -1 '送信元アカウントを取得 strSendAccount = Sheets(1).Range("SendAccount").Value '送信元アカウントが未選択の場合終了 If strSendAccount = "" Then MsgBox "送信元アカウントを設定してください。" End End If '送信元アカウントにアンダーバーをセット strSendAccount = strSendAccount + cstUnderscore With cdoConf.Fields .Item(cstSendusing) = 2 .Item(cstSmtpserver) = Sheets(1).Range(strSendAccount & "smtpserver").Value .Item(cstSmtpserverport) = Sheets(1).Range(strSendAccount & "smtpserverport").Value .Item(cstSendusername) = Sheets(1).Range(strSendAccount & "sendusername").Value .Item(cstSendpassword) = Sheets(1).Range(strSendAccount & "sendpassword").Value .Item(cstSmtpauthenticate) = True .Item(cstSmtpusessl) = True .Update End With 'Fromアドレス取得 FromAddress = Sheets(1).Range(strSendAccount & "From").Value '重要度を変更 cdoMsg.Fields.Item("urn:schemas:mailheader:X-Priority") = 1 cdoMsg.Fields.Update '-------各メールフォーマットから取得------- 'シート名を取得 SheetName = Sheets(i).Name '-------メール情報を取得------- 'セル内改行(LF)はCRLFに置換 → Yahooでは落ちるため ToAddress = Replace(Sheets(i).Range("Mail_TO").Value, vbLf, vbCrLf) 'To宛先 CcAddress = Replace(Sheets(i).Range("Mail_CC").Value, vbLf, vbCrLf) 'cc宛先 BccAddress = Replace(Sheets(i).Range("Mail_BCC").Value, vbLf, vbCrLf) 'bcc宛先 strSubject = Replace("【" & SheetName & "様】" & _ Sheets(i).Range("Mail_Subject").Value, vbLf, vbCrLf) '件名 strMailBody = Replace(Sheets(i).Range("Mail_Body").Value, vbLf, vbCrLf) 'メール本文 strSignature = Replace(Sheets(i).Range("Mail_Signature").Value, vbLf, vbCrLf) '署名 '-------メールに情報をセットする------- With cdoMsg Set .Configuration = cdoConf .From = FromAddress .To = ToAddress .CC = CcAddress .BCC = BccAddress .MDNRequested = True .Subject = strSubject .TextBody = strMailBody & vbCrLf & vbCrLf & strSignature .BodyPart.Charset = "utf-8" End With '-------添付ファイルを貼り付ける------- '[yyyymmdd_会社名].[拡張子]を検索し、取得する strAttachmentsPath() = FileSearch(Format(Now(), "yyyymmdd") & "_" & SheetName & ".*", MyDir & "\添付ファイル\") '" If strAttachmentsPath(0) = "dummy" Then '添付ファイルが一件もなければ、次のメール処理へ行く(発注連絡が不要なため) GoTo nextDO Else '添付ファイルが一件でもあれば添付 'ファイル件数分ループして添付する For j = 0 To UBound(strAttachmentsPath()) 'ファイルパスを取得 strAttachmentPath = strAttachmentsPath(j) 'ファイルを添付 cdoMsg.AddAttachment strAttachmentPath Next j End If '-------メールを送信する------- 'メール送信 cdoMsg.Send nextDO: '-------Outlookを閉じる(オブジェクトを解放)--- Set cdoMsg = Nothing Set cdoConf = Nothing Next i MsgBox "送信が完了しました。" 'エラーキャッチ ErrCatch: ' エラーの場合、エラーメッセージを表示する Call ShowErrMsg End Sub |
メール送信処理の解説
送信元アカウント情報を設定(メインシートから取得)
strSendAccount = Sheets(1).Range(“SendAccount”).Value
でメインシートの名前「SendAccount」からアカウント名を取得しています。
その後取得したアカウント名とSMTPServerやPortNumberの名前を文字連結して送信するための情報を取得しています。
送信元アカウントでGmailを選んだなら.Range(strSendAccount & “smtpserver”).Valueの中身はRange(“Gmail_smtpserverport)”.Value
Yahooを選んだならRange(“Yahoo_smtpserverport”).Valueのようになります。
メール情報を取得
ここでは改行コードLFをCRLFに置換しています。
なぜかと言うとYahooで送信する場合は、エラーになるためです。
改行コードがCRとLFではなく、LFだけの行があるために、エラー
メールが送信できるようになった より
改行があっても動いて欲しいものですが、仕様なら仕方ありませんね…
メールに情報をセットする
ここではメールのオブジェクトに件名や宛先などをセットしています。
添付ファイルを貼り付ける
FileSearchメソッドを使って、添付ファイルのパスを取得しメールのオブジェクトに張り付ける処理を行っています。
FileSearchは後で説明を記載しています。
その後、添付ファイルがない場合、メールは送らず次のシートを処理するようになっています。
※発注連絡という想定なので、発注書の添付ファイルがなければ連絡はする必要がないから送らないという考え方です。
メール添付ファイル取得 FileSearchメソッド
送信対象のファイル([yyyymmdd_シート名.拡張子]フォーマット)のファイル名を検索し配列に格納する処理です。
検索する場所は「..\VBA Outlookメール送信\添付ファイル」以下のみです。
他の場所に配置したファイルは添付ファイルとして検索されません。
コード
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 |
'============================== '目的 :添付ファイルを検索し、ファイルのパスを取得する '引数 :SearchText 検索するファイル名 ' :SearchPath 検索するパス '戻り値 : ファイルパスの配列 '============================== Private Function FileSearch(SearchText As String, SearchPath As String) As String() Dim FileName As String Dim Cnt As Long Dim Files() As String 'ファイルパス格納用配列 '中身をダミー値でセット ReDim Files(0) Files(0) = "dummy" 'ファイルを検索 FileName = Dir(SearchPath & "\" & SearchText) Do While FileName <> "" 'ファイル名を返却用配列に格納 ReDim Preserve Files(Cnt) As String Files(Cnt) = SearchPath & FileName Cnt = Cnt + 1 ' 次のファイル名を参照 FileName = Dir() Loop FileSearch = Files() End Function |
解説
引数として受け取った検索フォルダ(SearchPath)を検索条件(SearchText)を元に検索します。
見つかったファイルのパスを配列に格納していきます。
検索条件に一致するファイルが見つからなくなったら配列を呼び出し元に返しています。
エラー表示 ShowErrMsgメソッド
エラーをキャッチするメソッドです。
予測できないエラーがあればここでキャッチしてエラーがあったことをメッセージ表示します。
コード
1 2 3 4 5 6 7 8 9 10 11 12 13 |
'============================== '目的 :エラーの場合、エラーメッセージを表示する '============================== Public Sub ShowErrMsg() 'エラーがあればメッセージ表示 If Err.Number <> 0 Then MsgBox "想定外のエラーが発生しました。" & vbCrLf + _ "エラー番号:" + CStr(Err.Number) & vbCrLf + _ "エラーの種類:" + Err.Description End If End Sub |
解説
エラーがあった場合、そのエラー番号とエラー内容をメッセージ表示します。
送信結果
送信結果はこんなメールです。
・メールを送信する
http://officetanaka.net/excel/vba/tips/tips45.htm
・「 Gmailで相手に一斉に送信するエクセルマクロ」のコメント一覧
http://bzowner.blog.fc2.com/blog-entry-2.html?sp&m2=res
・CDO.Messageによるメール送信
http://serialty.blog117.fc2.com/blog-entry-10.html
・iCloud メールクライアント向けのメールサーバ設定
https://support.apple.com/ja-jp/HT202304
・CDOでメール送信
http://www.asahi-net.or.jp/~ef2o-inue/vba_o/sub05_800_080.html
・VBAでメール送信する
https://excel-ubara.com/excelvba4/EXCEL233.html
・VBAでGmail送信!CDOを活用してメールを操作する方法
http://www.fastclassinfo.com/entry/vba_gmail_sendmail
・メールが送信できるようになった
https://ajya.hatenablog.jp/entry/2012/03/22/223917
・CDO の概要
https://msdn.microsoft.com/ja-jp/library/cc446847.aspx
・【Excel VBA】【マクロ】【Tips】Sgn関数はExcel64bit版では使えない?