【VBA】ユーザー目線で開発する４

2021年7月1日

ユーザーフォームに機能を実装する

初冷房つけました。jimです。どうも✋

さっそく【VBA】ユーザー目線で開発する３の続きいきます。

用意したユーザーフォームを実行して表示してみます。

はい、テキストボックスに文字を入力することはできますが、ボタンを押しても何も起こりません。

今回は、これらのオブジェクトに機能を実装していきます👈

とりあえず、VBEのユーザーフォームを右クリックし『コードの表示』を選択。コードを表示します。（もしくはF7）

次に、下図の赤枠を変更して、３つのプロシージャを用意します。（手打ちでもOK）

↓の３つです。

Option Explicit

Private Sub CommandButton1_Click()

End Sub

Private Sub CommandButton2_Click()

End Sub

Private Sub UserForm_Initialize()

End Sub

それではこれから順番に記述していきます。

初期化

まずは『UserForm_Initialize』からです。

ユーザーフォームが表示される時に実行されます。

どんな機能を実装するかというと、まずユーザーフォームのキャプションにユーザー名を入力します。

次に、データベースにキャプション名と同じユーザー名があるかを問い合わせます。

そして、ユーザー名があった場合、項目がNullでなければテキストボックスにデータを入力。っと、いった感じのものです。

Const dbName = "\\共有サーバー\適当.accdb"
Private Sub UserForm_Initialize()
Dim adoCn, adoRs As Object
Dim sqlStr As Object
Dim WshNetworkObject As Object
    Set WshNetworkObject = CreateObject("WScript.Network")
    UserForm1.Caption = WshNetworkObject.username
    Set adoCn = CreateObject("ADODB.Connection")
    Set adoRs = CreateObject("ADODB.Recordset")
    adoCn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data source=" & dbName & ";"
    sqlStr = "SELECT * FROM 個人設定 WHERE ユーザー名 ='" & UserForm1.Caption & "' ;"
    adoCn.Open sqlStr, adoCn
    If adoRs.EOF = True Then
        If IsNull(adoRs!名字) = False Then TextBox1.Value = adoRs!名字
        If IsNull(adoRs!名前) = False Then TextBox1.Value = adoRs!名前
        If IsNull(adoRs!メールアドレス) = False Then TextBox1.Value = adoRs!メールアドレス
        If IsNull(adoRs!保存先) = False Then TextBox1.Value = adoRs!保存先
    End If
    adoRs.Close
    adoCn.Close
End Sub

挿入と更新

次は『CommandButton1_Click』です。

初期化同様に、ユーザーフォームのキャプション名から、データの有無を問い合わせます。

データがある場合はUPDATEのSQL文、ない場合はINSERTのSQL文を作成。

最後に、実行してユーザーフォームを閉じます。

Private Sub CommandButton1_Click()
Dim adoCn, adoRs As Object
Dim sqlStr As Object
    Set adoCn = CreateObject("ADODB.Connection")
    Set adoRs = CreateObject("ADODB.Recordset")
    adoCn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data source=" & dbName & ";"
    sqlStr = "SELECT * FROM 個人設定 WHERE ユーザー名 ='" & UserForm1.Caption & "' ;"
    adoCn.Open sqlStr, adoCn
    If adoRs.EOF = True Then
        sqlStr = "INSERT INTO 個人設定"
        sqlStr = sqlStr & "(ユーザー名,名字,名前,メールアドレス,保存先)"
        sqlStr = sqlStr & " VALUES ('" & UserForm1.Caption & "'"
        sqlStr = sqlStr & " ,'" & TextBox1.Value & ","
        sqlStr = sqlStr & " ,'" & TextBox2.Value & ","
        sqlStr = sqlStr & " ,'" & TextBox3.Value & ","
        sqlStr = sqlStr & " ,'" & TextBox4.Value & ",) ;"
    Else
        sqlStr = "UPDATE 個人設定"
        sqlStr = sqlStr & " SET 名字 ='" & TextBox1.Value & ","
        sqlStr = sqlStr & " , 名前 ='" & TextBox2.Value & ","
        sqlStr = sqlStr & " , メールアドレス ='" & TextBox3.Value & ","
        sqlStr = sqlStr & " , 保存先 ='" & TextBox4.Value & ","
        sqlStr = sqlStr & " WHERE ユーザー名 ='" & UserForm1.Caption & "' ;"
    End If
    adoRs.Close
    adoRs.Open sqlStr, adoCn
    adoRs.Close
    adoCn.Close
    Unload UserForm1
    MsgBox "挿入/更新が完了しました", vbOKOnly, "完了"
End Sub

削除

最後は『CommandButton2_Click』です。

これは単純に『キャプション名と同じデータがあれば削除する。』というSQL文を実行し、ユーザーフォームを閉じます。

挿入/更新も削除もですが、最後にユーザーフォームを非表示じゃなく閉じるにしたのは、テキストボックスをリセットするコードを削りたかったからです。

Private Sub CommandButton2_Click()
Dim adoCn, adoRs As Object
Dim sqlStr As Object
    Set adoCn = CreateObject("ADODB.Connection")
    Set adoRs = CreateObject("ADODB.Recordset")
    adoCn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data source=" & dbName & ";"
    sqlStr = "DELETE FROM 個人設定"
    sqlStr = sqlStr & " WHERE ユーザー名 ='" & UserForm1.Caption & "' ;"
    adoCn.Open sqlStr, adoCn
    adoRs.Close
    adoCn.Close
    Unload UserForm1
    MsgBox "削除が完了しました", vbOKOnly, "完了"
End Sub

実装まとめ

Option Explicit
Const dbName = "\\共有サーバー\適当.accdb"
Private Sub CommandButton1_Click()
Dim adoCn, adoRs As Object
Dim sqlStr As Object
    Set adoCn = CreateObject("ADODB.Connection")
    Set adoRs = CreateObject("ADODB.Recordset")
    adoCn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data source=" & dbName & ";"
    sqlStr = "SELECT * FROM 個人設定 WHERE ユーザー名 ='" & UserForm1.Caption & "' ;"
    adoCn.Open sqlStr, adoCn
    If adoRs.EOF = True Then
        sqlStr = "INSERT INTO 個人設定"
        sqlStr = sqlStr & "(ユーザー名,名字,名前,メールアドレス,保存先)"
        sqlStr = sqlStr & " VALUES ('" & UserForm1.Caption & "'"
        sqlStr = sqlStr & " ,'" & TextBox1.Value & ","
        sqlStr = sqlStr & " ,'" & TextBox2.Value & ","
        sqlStr = sqlStr & " ,'" & TextBox3.Value & ","
        sqlStr = sqlStr & " ,'" & TextBox4.Value & ",) ;"
    Else
        sqlStr = "UPDATE 個人設定"
        sqlStr = sqlStr & " SET 名字 ='" & TextBox1.Value & ","
        sqlStr = sqlStr & " , 名前 ='" & TextBox2.Value & ","
        sqlStr = sqlStr & " , メールアドレス ='" & TextBox3.Value & ","
        sqlStr = sqlStr & " , 保存先 ='" & TextBox4.Value & ","
        sqlStr = sqlStr & " WHERE ユーザー名 ='" & UserForm1.Caption & "' ;"
    End If
    adoRs.Close
    adoRs.Open sqlStr, adoCn
    adoRs.Close
    adoCn.Close
    Unload UserForm1
    MsgBox "挿入/更新が完了しました", vbOKOnly, "完了"
End Sub
Private Sub CommandButton2_Click()
Dim adoCn, adoRs As Object
Dim sqlStr As Object
    Set adoCn = CreateObject("ADODB.Connection")
    Set adoRs = CreateObject("ADODB.Recordset")
    adoCn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data source=" & dbName & ";"
    sqlStr = "DELETE FROM 個人設定"
    sqlStr = sqlStr & " WHERE ユーザー名 ='" & UserForm1.Caption & "' ;"
    adoCn.Open sqlStr, adoCn
    adoRs.Close
    adoCn.Close
    Unload UserForm1
    MsgBox "削除が完了しました", vbOKOnly, "完了"
End Sub
Private Sub UserForm_Initialize()
Dim adoCn, adoRs As Object
Dim sqlStr As Object
Dim WshNetworkObject As Object
    Set WshNetworkObject = CreateObject("WScript.Network")
    UserForm1.Caption = WshNetworkObject.username
    Set adoCn = CreateObject("ADODB.Connection")
    Set adoRs = CreateObject("ADODB.Recordset")
    adoCn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data source=" & dbName & ";"
    sqlStr = "SELECT * FROM 個人設定 WHERE ユーザー名 ='" & UserForm1.Caption & "' ;"
    adoCn.Open sqlStr, adoCn
    If adoRs.EOF = True Then
        If IsNull(adoRs!名字) = False Then TextBox1.Value = adoRs!名字
        If IsNull(adoRs!名前) = False Then TextBox1.Value = adoRs!名前
        If IsNull(adoRs!メールアドレス) = False Then TextBox1.Value = adoRs!メールアドレス
        If IsNull(adoRs!保存先) = False Then TextBox1.Value = adoRs!保存先
    End If
    adoRs.Close
    adoCn.Close
End Sub

これでDBの読み書きがユーザーフォームで出来るようになりました。

次回は、このDBを使った『例えばツール』を紹介します。んじゃまたね✋

Access,SQL,VBA,データベース,プログラミング

Posted by jim