Microsoft CDOを使うハメになったきっかけ
取引先に毎週送信するExcelファイルがありまして。
日々データを入力しておいて決まった曜日に1週間分を別名保存+原紙の初期化して、その別名保存したファイルを送っているんです。
最初はチマチマ手作業でやっていたんですが「こんなもんいちいちやってられるか！」+「ボタンクリックで全部できればほかの人に託せるじゃん？」という思いからVBAを使ったプログラムで自動化しておりました。（やったのは自分ではなく上司ですが）
使用していた手法は「dzsmtp.dll」を使用したメールサーバ経由の直接送信だったんですが、会社のシステムが入れ替わりOSがXP→７へ変わったのと同時にAccessも2003から2010へバージョンアップした際に（この辺りは以前少し日記代わりでかいたような）メール送信が動かなくなっていたんです。
もっと早く直したかったんですが、最近倉庫内の作業応援が忙しくてなかなか時間が取れなかったので今頃となってしまったというわけです。
では前置きが長くなりましたが別の手法として「Microsoft CDO」を用いたメール送信に取り組みたいと思います。
Microsft CDOの概要と使用法
まずは概要を。
簡単に言えば「プログラムから直接メールサーバを経由してメッセージを送信する」ための仕組みと言えるでしょう。
概要とはいえ単純すぎますかね（汗
詳しいことはマクロソフトのサイトをご覧頂いたほうがわかりやすいと思うので参考までに。
これを使えば正に「ボタンをクリックするだけで簡単メール送信♪」みたいな機能を実装できるわけですね。
うちの事務所、パソコンが得意でない方ばかりなのでこういう機能はとても助かります。
事前準備で参照設定を行う
まずは何より事前準備を。
調べたところ二通りあるようで一つは参照設定を予め行っておく、もう一つは実行時にバインディングするようにコード内に記述するというものなんですがここでは参照設定で進めます。
やり方はVBEを起動させた状態で「ツール」→「参照設定」とクリックしていきます。すると参照設定用のウィンドウが開きますので以下のように「Microsoft CDO for Windows 2000 Library」を探し出してチェックを入れればOK！
事前準備はこれだけ。では実際のコードへと移りましょう。
コードを見てみる
Sub メール送信()
Dim MailSmtpServer As String
Dim MailFrom As String
Dim MailTo As String
Dim MailSubject As String
Dim MailBody As String
Dim MailAddFile As Variant
Dim strMSG As String
' 添付ファイルの選択
MailAddFile = "添付ファイルのパス"
' 送信確認
If MsgBox("メールを送信します。" & vbCr & _
"SMTP,発信者,宛先等は正しいですか？", vbYesNo) <> vbYes Then Exit Sub
MailSmtpServer = "smtp.example.com" ' SMTPサーバ
MailFrom = "sendmail@example.com" ' 発信者
MailTo = "recievemail.example.com" ' 宛先
MailSubject = "title" ' 件名
MailBody = "body" ' 本文
' メール送信(CC,BCCはブランク)
strMSG = SendMailByCDO(MailSmtpServer, MailFrom, MailTo, "", "", _
MailSubject, MailBody, MailAddFile)
' 文字コードを任意に指定する場合は以下のようにします。
' strMSG = SendMailByCDO(MailSmtpServer, MailFrom, MailTo, "", "", _
MailSubject, MailBody, MailAddFile, cdoISO_2022_JP)
If strMSG <> "OK" Then MsgBox Mid(strMSG, 3)
MsgBox "メール送信終了"
End Sub
'*******************************************************************************
' メール送信(CDO)
'*******************************************************************************
' [引数]
' ①MailSmtpServer : SMTPサーバ名(又はIPアドレス)
' ②MailFrom : 送信元アドレス
' ③MailTo : 宛先アドレス(複数の場合はカンマで区切る)
' ④MailCc : CCアドレス(複数の場合はカンマで区切る)
' ⑤MailBcc : BCCアドレス(複数の場合はカンマで区切る)
' ⑥MailSubject : 件名
' ⑦MailBody : 本文(改行はvbCrLf付加)
' ⑧MailAddFile : 添付ファイル(複数の場合はカンマで区切るか配列渡し) ※Option
' ⑨MailCharacter : 文字コード指定(デフォルトはShift-JIS) ※Option
' [戻り値]
' 正常時："OK", エラー時："NG"+エラーメッセージ
'*******************************************************************************
Private Function SendMailByCDO(MailSmtpServer As String, _
MailFrom As String, _
MailTo As String, _
MailCc As String, _
MailBcc As String, _
MailSubject As String, _
MailBody As String, _
Optional MailAddFile As Variant, _
Optional MailCharacter As String)
Const cnsOK = "OK"
Const cnsNG = "NG"
Dim objCDO As New CDO.Message
Dim vntFILE As Variant
Dim IX As Long
Dim strCharacter As String, strBody As String, strChar As String
On Error GoTo SendMailByCDO_ERR
SendMailByCDO = cnsNG
' 文字コード指定の確認
If MailCharacter <> "" Then
' 指定ありの場合は指定値をセット
strCharacter = MailCharacter
Else
' 指定なしの場合はShift-JISとする
strCharacter = cdoShift_JIS
End If
' 本文の改行コードの確認
' Lfのみの場合Cr+Lfに変換
strBody = Replace(MailBody, vbLf, vbCrLf)
' 上記で元がCr+Lfの場合Cr+Cr+LfになるのでCr+Lfに戻す
MailBody = Replace(strBody, vbCr & vbCrLf, vbCrLf)
With objCDO
With .Configuration.Fields ' 設定項目
.Item(cdoSendUsingMethod) = cdoSendUsingPort ' 外部SMTP指定
.Item(cdoSMTPServer) = MailSmtpServer ' SMTPサーバ名
.Item(cdoSMTPServerPort) = 25 ' ポート№
.Item(cdoSMTPConnectionTimeout) = 60 ' タイムアウト
.Item(cdoSMTPAuthenticate) = cdoAnonymous ' 0
.Item(cdoLanguageCode) = strCharacter ' 文字セット指定
.Update ' 設定を更新
End With
.MimeFormatted = True
.Fields.Update
.From = MailFrom ' 送信者
.To = MailTo ' 宛先
If MailCc <> "" Then .CC = MailCc ' CC
If MailBcc <> "" Then .BCC = MailBcc ' BCC
.Subject = MailSubject ' 件名
.TextBody = MailBody ' 本文
.TextBodyPart.Charset = strCharacter ' 文字セット指定(本文)
' 添付ファイルの登録(複数対応)
If ((VarType(MailAddFile) <> vbError) And _
(VarType(MailAddFile) <> vbBoolean) And _
(VarType(MailAddFile) <> vbEmpty) And _
(VarType(MailAddFile) <> vbNull)) Then
If IsArray(MailAddFile) Then
For IX = LBound(MailAddFile) To UBound(MailAddFile)
.AddAttachment MailAddFile(IX)
Next IX
ElseIf MailAddFile <> "" Then
vntFILE = Split(CStr(MailAddFile), ",")
For IX = LBound(vntFILE) To UBound(vntFILE)
If Trim(vntFILE(IX)) <> "" Then
.AddAttachment Trim(vntFILE(IX))
End If
Next IX
End If
End If
.Send ' 送信
End With
Set objCDO = Nothing
SendMailByCDO = cnsOK
Exit Function
'-------------------------------------------------------------------------------
SendMailByCDO_ERR:
SendMailByCDO = cnsNG & err.Number & " " & err.Description
On Error Resume Next
Set objCDO = Nothing
End Function
順を追って見てみましょう。といっても主なセクションは2つだけ。
まず前半はSub メール送信() ～ End Subで囲まれている部分。ここはメールサーバや送信アドレス、宛先に件名に本文に・・・と今回送信するメールに関する記述を行ってメールを送信を指示するセクションになっています。
この部分の最後のほうに「SendMailByCDO（～）」という関数が出てきまして、その定義を行っているのが後半のPrivate Function ～ End Functionで括られた部分になる、というわけです。
こんな簡単に使えるならもっと早いうちにシステムを直せてたような・・・
まとめ
今回の作業はとても簡単なものでした。いや、中身を深く理解しようと思ったらめんどくさいんでしょうが今回はひとまず動けばOK！ぐらいのノリで試したものなので。
忘れないうちにまとめておくと
- Windows標準のライブラリを使用することでVBAから直接メール送信が可能。
- その名は「Microsoft CDO Library」
- 今回はAccessで動かしたがExcelでも実行可能。その場合セルに格納した値を引数にはめ込むこともできるみたい
といったところです。
あと、今回は試していませんが添付ファイルを選択できるように「ファイルを開く」ダイアログと組み合わせたり、テーブルにスケジュールをデータ化して保存しておいて区分を選択することでひとつのフォームのボタンから複数パターンのメールを送るとかもできそうですね。