在庫管理システムを作っていて「【安全在庫】に引っかかる品目が現れたら管理者にEメールを飛ばしたい」と思っていました。
「さすがにAccessからはEメールは送れないだろう」と調べもしておりませんでしたが、できるのですね。
以下のサイトを参考にしてサンプルファイルを作って実行してみましたら、すんなり成功しました。
参考にしたサイト
在庫管理システムについては⇩
-
-
簡易的にAccessデータベースで在庫管理システムを作成(サンプル付)
必要に迫られてAccessにて在庫管理・在庫検索・入出庫処理・入出庫履歴・在庫転送・単位変換、マスターデータの修正等々を装備したデータベースを構築しました。フォーム(分割フォームやサブフォーム)・クエリ・VBAを使っています。
続きを見る
フォーム
フォームには「送信」のコマンドボタン(コントロール名:cmd_送信)を配置したのみです。
【プロパティシート】-【イベント】タブ-【クリック時】を「イベントプロシージャ」に変え、右横の【…】をクリックしてVBエディタを開きます。
テーブル
テーブルは2つあります。
T_社員
メールアドレス・パスワードの情報が入ったテーブルです。
T_メール送信履歴
送信履歴を残します。「送信日時」と「本文」が格納されています。送信に成功しますと、「可否」がTrueとなり、チェックが入ります。何らかのエラーで送信失敗時はFalseになります。
ここではサンプルですので、実用化するには「宛先」「cc:」「エラーコード」などのフィールドも必要かと思います。
VBAコード
最初の設定
VBエディタを開きましたら、最初に【ツール】-【参照設定】をクリックします。

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

コード
フォームのVBAコードは以下の通りです。VBエディタにコピペします。
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 |
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の引数とすることも可能です。
例えば
1 |
Public Function cdoSendMail(txtアドレス As String,txtパスワード as String) As Boolean |
として呼び出し側から渡してやればこのFunction内から「T_社員」テーブルを参照している処理を削除できます。

余談
試していませんが、Excelでも使用可能だろうと思います。sheet内にボタンを配置してVBAコードを実行させればできるかと思います。
サンプルダウンロード
ファイルを最初に開く際に「コンテンツの有効化」をクリックしてください。

拡張子を.mdbにしてあります。Access2002以降で開けると思います。
ダウンロードはこちら
最後に
余計なお節介ですが、
メールのパスワードが入っていますので、ここだけ別のAccessデータベースにし、管理者パスワードを掛けるか、データベースごと暗号化するなどした方がよいかと思います。
また、会社の業務にて使用される場合には、このためだけのメールのアカウントをシステム管理者に発行をお願いすると良いかと思います。
余談ですが、どこの誰かわらない人にEメールのパスワードを特定されてしまい、踏み台にされて大量のスパムメールを全世界に配信されたことがあります。Biglobeから「警告書」が届いて慌ててパスワードを変更した覚えがあります。