見出し画像

7.[PG3]Accessで、データ入力フォーム作成とメール送信してみよう　その4

ひさき志向

こちら第７回「プログラマー養成講座」のパート4になります！
目次はこちらからご参照下さい！

前回までのあらすじ：テーブル、フォームの作成が終わり、いよいよVBAを書くことになりました！

では、ここからは、ちょっと自力で進めてみて下さい。
そうですね、目安として５分間、一歩も前に進めないようなことがあれば、その時は教えて下さい。ヒントとか出します！

プログラムの大枠の構造的には、Excelのファイル名変更の時と、大きく変わらないと思っています。データの取得、ループ、処理など。

前はシート上にファイル名変更の結果を出力しましたが、今回は正常にメール送信できた時だけテーブルの「SendDateTime」に日時を入れて下さい。異常時は空のままで。可能であればエラーの旨をメッセージ出力しましょうか。「ID〇のメール送信に失敗しました。処理を中断します。」とか。

あとはUserNameの扱いについてですが、MailTitleとMailBody内に{UserName}と記載があれば、それをUserNameに置き換えて下さい。定型文内に名前のところだけ埋め込みするみたいな感じを想定しています。

師匠

頑張ってみます。
Excelのファイル名変更のプログラムソースをちょっと見てみるか・・・。

Public Sub Jikkou()

'宣言
Dim i As Integer

'初期値設定
i = 1

'ループしてA行が、空になるまで処理
Do Until Worksheets("ファイル一覧").Cells(i, 1).Value = ""

If Worksheets("ファイル一覧").Cells(i, 1).Value = "ファイル操作.xlsm" Then
    Worksheets("ファイル一覧").Cells(i, 3).Value = "ファイル名は変更しない"

ElseIf Worksheets("ファイル一覧").Cells(i, 2).Value = "" Then
    Worksheets("ファイル一覧").Cells(i, 3).Value = "記入なし"

ElseIf Dir(ThisWorkbook.Path & "\" & Worksheets("ファイル一覧").Cells(i, 1).Value) = "" Then
    Worksheets("ファイル一覧").Cells(i, 3).Value = "A列のファイルが存在しません"

ElseIf Dir(ThisWorkbook.Path & "\" & Worksheets("ファイル一覧").Cells(i, 2).Value) <> "" Then
    Worksheets("ファイル一覧").Cells(i, 3).Value = "B列のファイルが存在しています"
        
Else
    Name ThisWorkbook.Path & "\" & Worksheets("ファイル一覧").Cells(i, 1).Value As ThisWorkbook.Path & "\" & Worksheets("ファイル一覧").Cells(i, 2).Value
    Worksheets("ファイル一覧").Cells(i, 3).Value = "ファイル名を変更しました"
End If

i = i + 1

Loop

End Sub

前に見た時は、結構長いと思ってたけど、こんなに短かったっけ・・・。
セル位置を覚えるための変数を数字宣言して、
変数に１を入れて、
あとはA列が””になるまでループしていくって感じかな。

今回は、
①まずテーブルからデータをとってきて、
②メール送信して、
③成功だったら、SendDateTimeに日時を入れて、
④失敗だったら、エラーメッセージを出して、
⑤終わり
って流れかな？

では検索するとして。。。
「AccessVBA テーブル」で検索してみようかな。
お、一番上に出てきたのが「ACCESS VBA テーブルの値を取得する方法」ってWEBサイトだ。見に行ってみよう。

ふむふむ、「DLookup」とかを使えば、指定したレコードが取れるのか。

DLookup("MailTo", "テーブル1", "ID=4")

こういう感じか。
あれ、赤くなっちゃってる！？

一応、やってみようかな・・・。

構文エラー・・・。検索してみようかな。

うーん、し、師匠・・・。エラーがどうすれば直るかわかりません。

はい。
まず上に書いてる①～⑤は良くまとめられてます。
しいて言えば、「メールアドレスが空の場合、処理しない」とか「メールドレスが変な場合、処理しない」とか書いてあれば更にGoodでしたが、今回自分で使うようと考えてそこらへんはOKとしましょう。
でも最低限、メール送信前に
「SendDateTimeが空の時に処理をする」は必要ですね。
さて、エラーについてですが、
これはDLookupで取ってきたものに、何をするか記載がないからエラーになっていますね。
例えば、最初に「Msgbox 」を書けばエラーが出なくなると思います。

師匠

ほんとだ！なおった！
でもIDがわからないから・・・
どうやってループ処理すれば・・・
うーん、「Access フィールド 空」とかで検索してみるか・・・
あ、これならIDが取れるんだ。
そうか、ひらめいた！！

Dim id As Integer
id = DLookup("ID", "テーブル1", "SendDateTime is null")

MsgBox DLookup("MailTo", "テーブル1", "ID = id")
MsgBox DLookup("MailFrom", "テーブル1", "ID = id")
MsgBox DLookup("MailCC", "テーブル1", "ID = id")
MsgBox DLookup("MailTitle", "テーブル1", "ID = id")
MsgBox DLookup("MailBody", "テーブル1", "ID = id")
MsgBox DLookup("UserName", "テーブル1", "ID = id")

こんな感じで、テーブルデータ全部取得できるし、
「SendDateTimeが空の時に処理をする」をクリアしてると思う！

Private Sub コマンド2_Click()

'宣言
Dim id As Integer
Dim MailTo As String
Dim MailFrom As String
Dim MailCC As String
Dim MailTitle As String
Dim MailBody As String
Dim UserName As String

id = DLookup("ID", "テーブル1", "SendDateTime is null")

MailTo = DLookup("MailTo", "テーブル1", "ID = id")
MailFrom = DLookup("MailFrom", "テーブル1", "ID = id")
MailCC = DLookup("MailCC", "テーブル1", "ID = id")
MailTitle = DLookup("MailTitle", "テーブル1", "ID = id")
MailBody = DLookup("MailBody", "テーブル1", "ID = id")
UserName = DLookup("UserName", "テーブル1", "ID = id")

MsgBox Mailsend(MailFrom, MailTo, MailCC, MailTitle, MailBody, "")

End Sub

あ、すごい。できた気がする。

あれ、駄目みたい・・・。
「Mailsend」で引っかかってるってことかな？

あー、今回はメールに「添付ファイル」はないので、
こんな感じで修正すれば動くと思います。

MsgBox Mailsend(MailFrom, MailTo, MailCC, MailTitle, MailBody)
↓
MsgBox Mailsend(MailFrom, MailTo, MailCC, MailTitle, MailBody,"")

最後の""ってところは、添付ファイルないよーって意味です。

師匠

なるほど、これで「True」がきてるってことはメール送信が成功しているってことですね。ふむふむ。じゃぁこれで完成するのでは！？

Private Sub コマンド2_Click()

'宣言
Dim id As Integer
Dim MailTo As String
Dim MailFrom As String
Dim MailCC As String
Dim MailTitle As String
Dim MailBody As String
Dim UserName As String

id = DLookup("ID", "テーブル1", "SendDateTime is null")

MailTo = DLookup("MailTo", "テーブル1", "ID = id")
MailFrom = DLookup("MailFrom", "テーブル1", "ID = id")
MailCC = DLookup("MailCC", "テーブル1", "ID = id")
MailTitle = DLookup("MailTitle", "テーブル1", "ID = id")
MailBody = DLookup("MailBody", "テーブル1", "ID = id")
UserName = DLookup("UserName", "テーブル1", "ID = id")

If Mailsend(MailFrom, MailTo, MailCC, MailTitle, MailBody, "") = True Then
    MsgBox "メール送信しました"
Else
    MsgBox "メール失敗しました"
End If

End Sub

あ、
＞③成功だったら、SendDateTimeに日時を入れて、
これ忘れてますね。

えっと、
「access データ更新」で検索してみよう。
あ、いや、こっちか
「accessVBA データ更新」

VBAの通常の関数ではレコードの更新ができません。
テーブルを操作する際はADOを使用する必要があります。

とあるサイトより

なんか難しいこと言われている気がするけど、関数だと無理なのかな。
DoCMDだとできるのかな？

DoCmd.RunSQL "UPDATE テーブル1 SET テーブル1.SendDateTime = date();"

ちがうか

DoCmd.RunSQL "UPDATE テーブル1 SET テーブル1.SendDateTime = date() WHERE ID = id;"

あれ、２件の更新！？
１件じゃないの？
データ取得するときはこれであってるのに。
「AccessVBA　検索　２件の更新」
（・・・）
駄目だ・・・５分経ったので、師匠ヘルプ・・・

なるほど。良い勉強になりそうなプログラムソースですね。
SQL文の作成まで突っ込んじゃってるんですね。いいですね。

まず、今止まっているとこですが、
率直に言うと、ひさきさんの想定通りにプログラム動いてないですねー。

師匠
DoCmd.RunSQL "UPDATE テーブル1 SET テーブル1.SendDateTime = date() WHERE ID = " & id & ";"

たぶん、本来の意図は、こう書くべきプログラムソースですね。
条件式を書く際に
「ID = id」としていますが、これだとうまく動きません。
ダブルコーテーションの中は、変数を書いても、ただのアルファベットとして認識されてしまいます。
これは上のDLookup関数のところでも同じです。

師匠

え、でもDLookupはうまくいっている気がするんですけど・・・

それは１件だけしかレコードがないから、そう見えるんですね。
５件くらい適当にレコードを入れて、
そのうちの最初の１件にSendDateTimeに日時を適当に入れてみて下さい。
そうすると、
id = DLookup("ID", "テーブル1", "SendDateTime is null")
でidは２件目のレコードが取得されると思います。
しかしDLookupで取れるのは１件目のデータになっていると思います。
これはDLookupの検索条件"ID = id"が意図通りに動いていないということになります。

師匠

本当だ。。。
ID=1,2,3,4,5ってあって、ID=1にSendDateTimeを入れたら、
idには2がはいったのに、
MailTo = DLookup("MailTo", "テーブル1", "ID = id")
でとってきたのはID=1のレコードのMailToだった・・・。
それでは、idのところをダブルコーテーションの外にして・・・
こんな感じかな。

Private Sub コマンド2_Click()

'宣言
Dim id As Integer
Dim MailTo As String
Dim MailFrom As String
Dim MailCC As String
Dim MailTitle As String
Dim MailBody As String
Dim UserName As String

id = DLookup("ID", "テーブル1", "SendDateTime is null")

MailTo = DLookup("MailTo", "テーブル1", "ID = " & id)
MailFrom = DLookup("MailFrom", "テーブル1", "ID = " & id)
MailCC = DLookup("MailCC", "テーブル1", "ID = " & id)
MailTitle = DLookup("MailTitle", "テーブル1", "ID = " & id)
MailBody = DLookup("MailBody", "テーブル1", "ID = " & id)
UserName = DLookup("UserName", "テーブル1", "ID = " & id)

If Mailsend(MailFrom, MailTo, MailCC, MailTitle, MailBody, "") = True Then
    MsgBox "メール送信しました"
    DoCmd.RunSQL "UPDATE テーブル1 SET テーブル1.SendDateTime = date() WHERE ID = " & id & ";"
Else
    MsgBox "メール失敗しました"
End If

End Sub

良し、動いたかな。
これで①～⑤の機能は全部満たしたかな？
完成しました！

ちょっと確認しますねー。
これは、ボタンを押したら１件ずつボタンを押す感じになってますが、ひさきさんの想定通りの動作でしょうか？

あと、UserNameの処理が丸っと抜けていますね。
トラブルがあって忘れちゃったかな？

師匠

あれ、これだとメール１件ずつ？
あ、ほんとだ、「SendDateTime is null」で５件分データ取ってきてて、５件分の処理しているのかと思っちゃってました。
UserNameは、忘れていました・・・。

気持ちはわかります！
でもこれは実は「SendDateTime is null の条件で抽出した１件目」ということです。条件が複数レコードを抽出する場合、１件目を取得してるんです。

では、UserNameのところはまた後でということで、
まずはループ処理のロジックを一緒に考えてみましょうか。

どうすれば、ループ処理で５件処理とかできると思いますか？

師匠

うーん、そういえば・・・
さっきDlookup調べているときに、DCountってのも見つけたんですよね。
これで５件とかだったら、５回ループするとか？

おー、なるほど。いいですね！
ちなみにDlookupでは、検索条件で引っかからないとNullを返す特性があるので、Nullが返ってくるまで繰り返すとかでも良かったかもしれません。

そしたら、DCountでプログラムを考えてみて下さい。

師匠

まずは現在の位置をカウントする変数が必要で、
あとは最大数を覚えとく変数が必要かな。
Excelのときのループと同じ感じでできるかな。

Private Sub コマンド2_Click()

'宣言
Dim count As Integer
Dim i As Integer

Dim id As Integer
Dim MailTo As String
Dim MailFrom As String
Dim MailCC As String
Dim MailTitle As String
Dim MailBody As String
Dim UserName As String

count = DCount("ID", "テーブル1", "SendDateTime is null")

Do Until i = count
id = DLookup("ID", "テーブル1", "SendDateTime is null")

MailTo = DLookup("MailTo", "テーブル1", "ID = " & id)
MailFrom = DLookup("MailFrom", "テーブル1", "ID = " & id)
MailCC = DLookup("MailCC", "テーブル1", "ID = " & id)
MailTitle = DLookup("MailTitle", "テーブル1", "ID = " & id)
MailBody = DLookup("MailBody", "テーブル1", "ID = " & id)
UserName = DLookup("UserName", "テーブル1", "ID = " & id)

If Mailsend(MailFrom, MailTo, MailCC, MailTitle, MailBody, "") = True Then
    MsgBox "メール送信しました"
    DoCmd.RunSQL "UPDATE テーブル1 SET テーブル1.SendDateTime = date() WHERE ID = " & id & ";"
Else
    MsgBox "メール失敗しました"
End If

i = i + 1

Loop

End Sub

よし、０件の時もエラーになってないっぽいし、これでOKかな。

だいぶ完成が近づいてきましたね。
以下４点ほど修正してみて下さい。

①メール送信成功時はmsgbox出さなくていいかと思います。１０件、２０件となるといちいちOK押さないと処理が止まるとちょっと・・・。

②メール送信失敗時は、メッセージを出すだけじゃなくて処理を止めて欲しい。その際に「ID〇〇でエラーがあったので処理を中断しました。」と表示するようにしましょうか。

③DoCmd.RunSQL実行時に、確認メッセージがでますよね？これNOにすると無限ループ的な感じになっちゃうし、NOされるとロジックがおかしくなってくるので確認メッセージがでないようにして下さい。確認メッセージは非表示と表示の切替ができますので、DoCmd.RunSQLの実行後は表示するように戻すのを忘れないようにしてください。

④最後に「ｘ件のメール送信処理を完了しました」とメッセージを出すようにしましょうか。何も言われないと、プログラムが動いているかわからないので。

師匠

わかりました！
①は簡単。コメントアウトするだけでいいんだからね。
②はメッセージはすぐだし、IDも変数にとってあるから大丈夫。「Access ループ 抜ける」で検索して。。。なるほど。。。「Exit Do」で良いのかな。
③もやる箇所はわかるから、検索だな。「docmd.runsql メッセージ 非表示」で出てきたサイトをそのまま参照しちゃおう。
④送信件数は、iでいいのかな。これもメッセージだけ変えれば、他はいじる必要なさそうかな。

Private Sub コマンド2_Click()

'宣言
Dim count As Integer
Dim i As Integer

Dim id As Integer
Dim MailTo As String
Dim MailFrom As String
Dim MailCC As String
Dim MailTitle As String
Dim MailBody As String
Dim UserName As String

count = DCount("ID", "テーブル1", "SendDateTime is null")

Do Until i = count

id = DLookup("ID", "テーブル1", "SendDateTime is null")

MailTo = DLookup("MailTo", "テーブル1", "ID = " & id)
MailFrom = DLookup("MailFrom", "テーブル1", "ID = " & id)
MailCC = DLookup("MailCC", "テーブル1", "ID = " & id)
MailTitle = DLookup("MailTitle", "テーブル1", "ID = " & id)
MailBody = DLookup("MailBody", "テーブル1", "ID = " & id)
UserName = DLookup("UserName", "テーブル1", "ID = " & id)

If Mailsend(MailFrom, MailTo, MailCC, MailTitle, MailBody, "") = True Then
    'MsgBox "メール送信しました"
    DoCmd.SetWarnings False
    DoCmd.RunSQL "UPDATE テーブル1 SET テーブル1.SendDateTime = date() WHERE ID = " & id & ";"
    DoCmd.SetWarnings True
Else
    MsgBox "ID" & id & "でエラーがあったので処理を中断しました。"
    Exit Do
End If

i = i + 1

Loop

MsgBox i & "件のメール送信処理を完了しました"

End Sub

いいですね、だいぶプログラムソースっぽくなってきました。
メール送信用フォームのプログラムは、これで完成で良いでしょう。
ループのやり方とか、ちょっと怪しいところもありましたが、
その後の修正なども、ほとんど一人でこなせているし、
プログラムソースの理解度は良い感じになってきていますね。
ただし、これはまだ素人が自分用にプログラムを作成したってレベルです。勉強用としては十分実用性があるプログラムになっていますが、足りないところがまだまだあります。
例えば、
・データ入力時に、メールアドレスの入力チェックをしていない
・本文の文字数制限を設けていない
・例えばレコードの「MailCC」などがNullの場合エラーになる
・SendDateTimeは、メール送信日時なのに、日付しか入っていない
・UserNameの代入処理が未実装
・入力フォームのUI／デザインが未成熟
などになります。

ただ、これらは「特別なセンス」「プログラムの天才」じゃないとできないようなものではありません。すべてプログラミングを重ねていけば誰でも習得できるものなので、あとで振り返った時や、プログラムの練習をするときに修正をしてみましょう。

師匠

わかりました、ありがとうございました！
これにて、

あ、ちなみに私が書いたサンプルコードも見ておきます？

師匠

ぜ　ぜ　ぜ　是非みたいです！

ある程度、違ってくるとは思っていたんですけど、ぜんぜん違うプログラムソースになってますよｗ

師匠
Private Sub コマンド2_Click()

'変数宣言
Dim daoDB As dao.Database
Dim daoRS As dao.Recordset

Dim strMailTitle As String
Dim strMailBody As String

Dim c As Integer

'TABLE読込
Set daoDB = CurrentDb()
Set daoRS = daoDB.OpenRecordset("Select * From テーブル1 Where SendDateTime Is Null", dbOpenDynaset, dbDenyWrite)

c = 0
If daoRS.RecordCount > 0 Then

    Do Until daoRS.EOF
        
        If daoRS!MailFrom <> "" And daoRS!MailTo <> "" Then
        
            strMailTitle = Replace(daoRS!MailTitle, "{UserName}", daoRS!UserName)
            strMailBody = Replace(daoRS!MailBody, "{UserName}", daoRS!UserName)
            
            If Mailsend(daoRS!MailFrom, daoRS!MailTo, daoRS!MailCC, strMailTitle, strMailBody, "") = True Then
                daoRS.Edit
                daoRS!SendDateTime = Now
                daoRS.Update

            Else
                MsgBox "ID:" & daoRS!id & " でエラーがあったので処理を中断しました。"
                Exit Do
            End If
        
        End If
        
        c = c + 1
        daoRS.MoveNext
    Loop

End If

MsgBox c & "件のメール送信処理を完了しました"

On Error Resume Next
Set daoRS = Nothing
Set daoDB = Nothing

End Sub

確かに違う・・・。これを想定していた・・・！？

想定していたってことはないです。

実際にひさきさんのプログラムと機能的に違うところは
UserNameの代入処理を実装しているくらいで、
他の挙動は殆ど一緒ですしね。

同じ挙動をするプログラムを書いたとしても、
書く人が違えば、これだけの違いがでてくるものなのですよ。

プログラムに対して「絶対答えのあるもの」と思ってる人がいますが、プログラム言語は、しょせん言語なので、書く人や翻訳する人によって、そのプログラムの結果が同じでも、ソースコードは全然変わってきちゃうんですよねってことです！

師匠

勉強になりました。。。ありがとうございました！

次回からは、VBAはここでいったん終わりになりまして、
いよいよ、ひさきが、世界に羽ばたくとき！！

WEB言語のPHPの世界に足を踏み込みます！お楽しみに！

この記事が気に入ったらサポートをしてみませんか？