AccessデータベースからEメールを送る（サンプル付き）

在庫管理システムを作っていて「【安全在庫】に引っかかる品目が現れたら管理者にEメールを飛ばしたい」と思っていました。

「さすがにAccessからはEメールは送れないだろう」と調べもしておりませんでしたが、できるのですね。

以下のサイトを参考にしてサンプルファイルを作って実行してみましたら、すんなり成功しました。

参考にしたサイト

在庫管理システムについては⇩

フォーム

フォームには「送信」のコマンドボタン（コントロール名：cmd_送信）を配置したのみです。

【プロパティシート】-【イベント】タブ-【クリック時】を「イベントプロシージャ」に変え、右横の【…】をクリックしてVBエディタを開きます。

テーブル

テーブルは2つあります。

T_社員

メールアドレス・パスワードの情報が入ったテーブルです。

T_メール送信履歴

送信履歴を残します。「送信日時」と「本文」が格納されています。送信に成功しますと、「可否」がTrueとなり、チェックが入ります。何らかのエラーで送信失敗時はFalseになります。

ここではサンプルですので、実用化するには「宛先」「cc:」「エラーコード」などのフィールドも必要かと思います。

VBAコード

最初の設定

VBエディタを開きましたら、最初に【ツール】-【参照設定】をクリックします。

【Microsoft CDO for Windows 2000 Library】にチェックをしてOKボタンを押します。

コード

フォームのVBAコードは以下の通りです。VBエディタにコピペします。

Option Compare Database

Private Sub cmd_送信_Click()
    Dim rs As DAO.Recordset
    Set rs = CurrentDb.OpenRecordset("T_メール送信履歴", dbOpenTable)
    
    With rs
        .AddNew
        .Fields("送信日時") = Now
        .Fields("本文") = "本文"
        .Fields("可否") = cdoSendMail
        .Update
    End With
    
    rs.Close
    Set rs = Nothing
End Sub

'------------------------------------------------------------
'   処理内容:CDOメール送信
'   引数:なし
'   戻り値:True/False
'   参考Webサイト：https://asbepartners.com/send_mail/
'------------------------------------------------------------
Public Function cdoSendMail() As Boolean

    Dim objCDO
    Dim MSgw
    
    Dim txtアドレス As String
    Dim txtパスワード As String
    Dim txt社員 As String
    Dim sql As String
    
    Dim rs As DAO.Recordset
    
    sql = "SELECT * FROM T_社員 WHERE 社員コード=" & 10001 'メールする人を選択
    Set rs = CurrentDb.OpenRecordset(sql)
    txtアドレス = rs.Fields("アドレス")
    txtパスワード = rs.Fields("パスワード")

    
    On Error GoTo Err_Exit
    
    '戻り値の初期化
    cdoSendMail = False
      
    Set objCDO = CreateObject("CDO.Message")
    
    'CDOのスキーマを定義
    MSgw = "http://schemas.microsoft.com/cdo/configuration/"
    
    With objCDO.Configuration.Fields
        'メール送信方法
        .Item(MSgw & "sendusing") = 2
        'SMTPサーバーのアドレス
        .Item(MSgw & "smtpserver") = "mail.biglobe.ne.jp" 'Biglobeでテストしました。各自の環境に合わせて要書き換えてください！
        'SMTPサーバーのポート
        .Item(MSgw & "smtpserverport") = 465 'Biglobeでテストしました。各自の環境に合わせて要書き換えてください！
        '差出人ユーザー名
        .Item(MSgw & "sendusername") = txtアドレス
        '認証コード
        .Item(MSgw & "sendpassword") = txtパスワード
        'SSL認証要
        .Item(MSgw & "smtpusessl") = True
        '認証方式(1)
        .Item(MSgw & "smtpauthenticate") = cdoBasic
        'タイムアウト
        .Item(MSgw & "smtpconnectiontimeout") = 60
        .Update
    End With
     
    '差出人メールアドレス
    objCDO.From = txtアドレス
    
    'あて先メールアドレス
    objCDO.To = txtアドレス '管理者のメールアドレスなどに書き換えてください
    
    'CCメールアドレス
    'objCDO.CC = Me.txtCC '必要に応じて書き換えてください
    
    '件名
    objCDO.subject = "送信テスト件名" '必要に応じて書き換えてください
    '本文
    objCDO.textBody = "送信テスト本文" '必要に応じて書き換えてください
    
    '文字化け対応のため追加
    objCDO.TextBodyPart.Charset = "ISO-2022-JP"
     
    objCDO.send
    
    MsgBox "メールを送信しました。", vbOKOnly + vbInformation, "送信完了"
    
    '正常終了
    cdoSendMail = True

    Set rs = Nothing
    rs.Close
    
    Exit Function
    
Err_Exit:
    MsgBox Err.Number & ":" & Err.Description, vbOKOnly + vbCritical, "cdoSendMail()"

End Function

100

101

102

103

104

105

Option Compare Database

Private Sub cmd_送信_Click()

Dim rs As DAO.Recordset

Set rs = CurrentDb.OpenRecordset("T_メール送信履歴", dbOpenTable)

With rs

.AddNew

.Fields("送信日時") = Now

.Fields("本文") = "本文"

.Fields("可否") = cdoSendMail

.Update

End With

rs.Close

Set rs = Nothing

End Sub

'------------------------------------------------------------

' 処理内容:CDOメール送信

' 引数:なし

' 戻り値:True/False

' 参考Webサイト：https://asbepartners.com/send_mail/

'------------------------------------------------------------

Public Function cdoSendMail() As Boolean

Dim objCDO

Dim MSgw

Dim txtアドレス As String

Dim txtパスワード As String

Dim txt社員 As String

Dim sql As String

Dim rs As DAO.Recordset

sql = "SELECT * FROM T_社員 WHERE 社員コード=" & 10001 'メールする人を選択

Set rs = CurrentDb.OpenRecordset(sql)

txtアドレス = rs.Fields("アドレス")

txtパスワード = rs.Fields("パスワード")

On Error GoTo Err_Exit

'戻り値の初期化

cdoSendMail = False

Set objCDO = CreateObject("CDO.Message")

'CDOのスキーマを定義

MSgw = "http://schemas.microsoft.com/cdo/configuration/"

With objCDO.Configuration.Fields

'メール送信方法

.Item(MSgw & "sendusing") = 2

'SMTPサーバーのアドレス

.Item(MSgw & "smtpserver") = "mail.biglobe.ne.jp" 'Biglobeでテストしました。各自の環境に合わせて要書き換えてください！

'SMTPサーバーのポート

.Item(MSgw & "smtpserverport") = 465 'Biglobeでテストしました。各自の環境に合わせて要書き換えてください！

'差出人ユーザー名

.Item(MSgw & "sendusername") = txtアドレス

'認証コード

.Item(MSgw & "sendpassword") = txtパスワード

'SSL認証要

.Item(MSgw & "smtpusessl") = True

'認証方式(1)

.Item(MSgw & "smtpauthenticate") = cdoBasic

'タイムアウト

.Item(MSgw & "smtpconnectiontimeout") = 60

.Update

End With

'差出人メールアドレス

objCDO.From = txtアドレス

'あて先メールアドレス

objCDO.To = txtアドレス '管理者のメールアドレスなどに書き換えてください

'CCメールアドレス

'objCDO.CC = Me.txtCC '必要に応じて書き換えてください

'件名

objCDO.subject = "送信テスト件名" '必要に応じて書き換えてください

'本文

objCDO.textBody = "送信テスト本文" '必要に応じて書き換えてください

'文字化け対応のため追加

objCDO.TextBodyPart.Charset = "ISO-2022-JP"

objCDO.send

MsgBox "メールを送信しました。", vbOKOnly + vbInformation, "送信完了"

'正常終了

cdoSendMail = True

Set rs = Nothing

rs.Close

Exit Function

Err_Exit:

MsgBox Err.Number & ":" & Err.Description, vbOKOnly + vbCritical, "cdoSendMail()"

End Function

Function cdoSendMailを「フォーム1」の中に書いていますが、各フォーム共通で使用する場合は標準モジュールに移動します。

このFunction内にて「T_社員」テーブルを参照して変数に入れていますが、Function cdoSendMailの引数とすることも可能です。

例えば

Public Function cdoSendMail(txtアドレス As String,txtパスワード as String) As Boolean

1	Public Function cdoSendMail(txtアドレス As String,txtパスワード as String) As Boolean

として呼び出し側から渡してやればこのFunction内から「T_社員」テーブルを参照している処理を削除できます。

Biglobeのメールアカウントを利用して自分宛てにメールしてみました。一部smtpサーバーの設定にBiglobeの設定が残っていますが、それは環境に合わせて書き換えの必要があります。
メールアドレス・パスワード・宛先・メールサーバーの設定、これらが揃わないとサンプルは動作しません。

余談

試していませんが、Excelでも使用可能だろうと思います。sheet内にボタンを配置してVBAコードを実行させればできるかと思います。

サンプルダウンロード

ファイルを最初に開く際に「コンテンツの有効化」をクリックしてください。

拡張子を.mdbにしてあります。Access2002以降で開けると思います。

ダウンロードはこちら

最後に

余計なお節介ですが、

メールのパスワードが入っていますので、ここだけ別のAccessデータベースにし、管理者パスワードを掛けるか、データベースごと暗号化するなどした方がよいかと思います。

また、会社の業務にて使用される場合には、このためだけのメールのアカウントをシステム管理者に発行をお願いすると良いかと思います。

余談ですが、どこの誰かわらない人にEメールのパスワードを特定されてしまい、踏み台にされて大量のスパムメールを全世界に配信されたことがあります。Biglobeから「警告書」が届いて慌ててパスワードを変更した覚えがあります。