ACCESS 名簿を考えてみる 3

2022年12月12日

ゴルフ練習場を見ている柴犬は「俺にはクラブが持てないからゴルフは分からない。ボールは追いかけるものだ」と思っているのでしょう。

今回の概要

開いた最初のフォーム画面です。

これは、ボタン「編集フォーム」をクリックした画面です。

一番上の新規レコードのレコードセレクタ（左端の黒い四角部分）をクリックしました。

すると、入力フォームが開きます。

また、「新規」が分かるように、IDの表示が「新規」となるようにしています。

次に、上から2つ目のレコードセレクタをクリックします。

すると、選択したレコードの内容がフォームに表示されます。

次に、例として新規に追加してみます。

新規レコードのレコードセレクタをクリックしてフォームを開きます。

名前以下必要事項を入力します。

そして、終了したらボタン「更新」をクリックします。

新しいレコードが追加されました。

確認のため、ボタン「選択フォーム」をクリックします。

期待通りに、新規レコードが確認できます。

フォーム「入力」

フォームの構成

フォーム1 のコントロールの配置は次のとおりです。

そして、コントロール名は「テーブル1」のフィールド名と一致するようにします。

すなわち、ID を「ID」、名前を「名前」、郵便番号を「郵便番号」、住所を「住所」とします。

テキストボックスの「コントロールソース」を全部削除して非連結にします。

テキストボックス「 ID 」の編集は想定しないので、編集ロックを「はい」にします。

フォームのプロパティは大体次のように設定しました。

「レコードソース」に「テーブル1」をセットしているのは、「既存のフィールドの追加」でドラッグアンドペーストでフォームにコントロールをセットするためです。

最終には、これを削除します。

コード

OpenArgs に呼び出したフォーム名（親フォーム名）がセットしてあるので、これを取得します。

続いて、親フォームのプロパティ「Data」からデータを取得して描画します。

コードは次のとおりです。

copy

Option Compare Database
Option Explicit

Private myParent            As String
Private memData             As Dictionary
'---------------------------------------
'このプロパティは主にアクティブが親フォームに戻った後、
'親フォームが参照します。
Public Property Set Data(ByRef myDict As Object)
    Set memData = myDict
End Property

Public Property Get Data() As Object
    Set Data = memData
End Property
'---------------------------------------
'
Private Sub Form_Open(Cancel As Integer)

    '親フォーム名を取得します。
    myParent = Me.OpenArgs

End Sub
'---------------------------------------
'
Private Sub Form_Load()
    Dim Ctrl                As Object
    Dim UF                  As Object
    Dim myDict              As Dictionary

    '------親フォームを探査します。
    For Each UF In Forms
        If UF.Name = myParent Then

            '------親フォームから呼び出したレコードのデータを取得します。
            Set myDict = UF.Data

            '------フォームのコントロールを探査します。
            For Each Ctrl In Me.Controls

                '------テキストボックスのみを対象にします。
                If TypeName(Ctrl) = "TextBox" Then
                    '------コントロール名とキーを照合します。
                    If myDict.Exists(Ctrl.Name) Then
                        '------照合できたら値をコントールにセットします。
                        Ctrl.Value = myDict(Ctrl.Name)
                    End If
                End If

            Next Ctrl
   
        End If
    Next UF

End Sub
'---------------------------------------
'
Private Sub bu更新_Click()
    Dim Ctrl                As Object

    '------フォーム2が参照するデータをセットします。
    Set memData = New Dictionary
    With Data
        For Each Ctrl In Me.Controls
            If TypeName(Ctrl) = "TextBox" Then
                .Add Ctrl.Name, Ctrl.Value
            End If
        Next Ctrl
    End With

    '------アクティブをフォーム2に移します。
    Me.Visible = False

End Sub
'---------------------------------------
'
Private Sub bu閉じる_Click()

    DoCmd.Close acForm, Me.Name

End Sub

フォーム「フォーム2 」

フォームの構成

作成したいフォームの最終形です。

テキストボックス「 BC 」「名前」「住所」「郵便番号」「 ID 」「 selected 」、ラベル「 Protect 」などを配置しています。

「 BC 」は黄色の帯を描画します。

「 Protect 」は「名前」などの蓋の役割をさせています。

つぎの式の意味は「selected」の文字列の中に「ID」がある場合、ggggggggggがセットされ、ない場合は空がセットされます。

=IIf(InStr([selected].[Value] & ",","," & [ID].[Value] & ",")>0,"gggggggggg","")

ここで、フォント「 Webdings 」は図形表現のようなもので、「 g 」は文字範囲を隙間なく「■」で表現します。

したがって、ｇは■なので■■■■■■■■■■が隙間なく黄色で表示されます。

ということは、レコード全体が黄色になります。

使い方によっては、この「■」1つを1つのピクセルのようにして、画像表現もできます。

しかし、文字と文字の境界が白く表現されますので、境界が目立たないように薄い黄色にしています。

コントロールの上で右クリックするとメニューが開きます。

そして、メニューの中ほどにある「位置」をクリックすると「最前面」「最背面」が選択できます。

「 BC 」は「最背面」に、「 Protect 」は「最前面」にします。

以上のように、セットして「フォーム2 」を開くと次のようになります。

コード

copy

Option Compare Database
Option Explicit

Private TargetList          As String
Private memData             As Dictionary
'---------------------------------------
'
Public Property Set Data(ByRef myDcit As Object)
    Set memData = myDict
End Property

Public Property Get Data() As Object
    Set Data = memData
End Property
'---------------------------------------
'
Private Sub Form_Open(Cancel As Integer)
    Dim mySQL               As String

    '------ユニオンSQLで空レコードをセットして表示します。
    mySQL = mySQL & "SELECT B.* FROM"
    mySQL = mySQL & " (SELECT"
    mySQL = mySQL & " A.ID"
    mySQL = mySQL & ", A.名前"
    mySQL = mySQL & ", A.住所"
    mySQL = mySQL & ", A.郵便番号"
    mySQL = mySQL & " FROM テーブル1 AS A"
    mySQL = mySQL & " UNION"
    '------空レコード
    mySQL = mySQL & " SELECT TOP 1"
    mySQL = mySQL & " '新規' AS ID"
    mySQL = mySQL & ", '' AS 名前"
    mySQL = mySQL & ", '' AS 住所"
    mySQL = mySQL & ", '' AS 郵便番号"
    mySQL = mySQL & " FROM テーブル1) AS B"
    mySQL = mySQL & " ORDER BY B.名前;"

    Me.RecordSource = mySQL

End Sub
'---------------------------------------
'
Private Sub Form_Click()
    Dim Ctrl                As Control
    Dim UF                  As Object
    Dim myData              As Dictionary
    Dim mySQL               As String
    Dim RES                 As String

    '------レコードセレクタをクリックしました。
    If Me.SelHeight > 0 Then

        '------レコードを黄色に塗ります。
        Me.selected.Value = "," & Me.ID.Value

        Me.Recalc

        '------レコードのデータを値、コントロール名をキーにした
        '      ハッシュテーブルを作成します。
        Set memData = New Dictionary
        With Data
            For Each Ctrl In Me.Controls
                If TypeName(Ctrl) = "TextBox" Then
                    .Add Ctrl.Name, Ctrl.Value
                End If
            Next Ctrl
        End With

        '------入力フォームを開きます。
        DoCmd.OpenForm "入力", acNormal, WindowMode:=acDialog, OpenArgs:=Me.Name

        '------入力フォームからアクティブが戻り開いているか確認します。
        For Each UF In Forms
            '------開いている。
            If UF.Name = "入力" Then
                '------入力フォームから入力状況を取得します。
                Set myData = UF.Data

                '------新規レコードの場合追加します。
                If myData("ID") = "新規" Then
                    Call InsertRun(myData, RES)
                    If RES = "" Then
                        Me.selected.Value = "," & DMax("ID", "テーブル1")
                    End If
                '------更新の場合修正します。
                Else
                    Call UpdateRun(myData, RES)
                End If

                '------エラーがなければ再クエリーします。
                If RES = "" Then
                    Me.Requery
                '------エラーメッセージを表示します。
                Else
                    MsgBox RES
                End If
                '------非表示のフォームを閉じます。
                DoCmd.Close acForm, "入力", acSaveNo
            End If
        Next UF

    End If

End Sub
'---------------------------------------
'
Private Sub InsertRun(ByRef myData As Dictionary, _
                      ByRef RES As String)
    Dim DB                  As DAO.Database
    Dim WSP                 As Workspace
    Dim mySQL               As String

    '------追加SQL文
    mySQL = "INSERT INTO テーブル1 ("
    mySQL = mySQL & "名前"
    mySQL = mySQL & ", 住所"
    mySQL = mySQL & ", 郵便番号)"
    mySQL = mySQL & " VALUES("
    mySQL = mySQL & "'" & myData("名前") & "'"
    mySQL = mySQL & ", '" & myData("住所") & "'"
    mySQL = mySQL & ", '" & myData("郵便番号") & "');"

    Call RunSQL(mySQL, RES)

End Sub
'---------------------------------------
'
Private Sub UpdateRun(ByRef myData As Dictionary, _
                      ByRef RES As String)
    Dim DB                  As DAO.Database
    Dim WSP                 As Workspace
    Dim Keys                As Variant
    Dim BUF                 As String
    Dim mySQL               As String

    '------更新SQL文
    mySQL = "UPDATE テーブル1 AS A"
    mySQL = mySQL & " SET"
    mySQL = mySQL & "【VALUES】"
    mySQL = mySQL & " WHERE A.ID = " & myData("ID") & ";"
    
    For Each Keys In memData
        If myData.Exists(Keys) Then
            '------元データと比較して異なっていれば更新します。
            If memData(Keys) <> myData(Keys) Then
                If BUF = "" Then
                    BUF = Keys & " = '" & myData(Keys) & "'"
                Else
                    BUF = BUF & ", " & Keys & " = '" & myData(Keys) & "'"
                End If
            End If
        End If
    Next Keys

    '------更新がなければmySQLを空にします。
    If BUF <> "" Then
        BUF = " " & BUF
        mySQL = Replace(mySQL, "【VALUES】", BUF)
    Else
        mySQL = ""
    End If

    If mySQL <> "" Then
        Call RunSQL(mySQL, RES)
    Else
        RES = "変更はありません。"
    End If

End Sub
'---------------------------------------
'
Private Sub RunSQL(ByVal mySQL As String, _
                   ByRef RES As String)
    Dim DB                  As DAO.Database
    Dim WSP                 As Workspace
    On Error GoTo Err_order

    Set WSP = DBEngine.Workspaces(0)
    Set DB = CurrentDb

    '------トランザクション処理開始
    WSP.BeginTrans

    DB.Execute mySQL
   
    If DB.RecordsAffected = 0 Then
        '------ロールバック処理
        WSP.Rollback
    Else
        '------トランザクション処理終了
        WSP.CommitTrans
    End If

Exit_order:

    '------WSP.Close は不要
    Set DB = Nothing
    Set WSP = Nothing
    Exit Sub

Err_order:

    RES = Err.Description
    '------トランザクション処理終了（処理をなかったことにする）
    WSP.Rollback

    Resume Exit_order

End Sub

フォーム「ベース」

ここでは、ボタン「編集フォーム」を新しく追加します。

そして、コントロール名は「bu3」とします。

コード

Private Sub Form_Load() の修正

２カ所修正します。

    '------ボタンのキャプションリスト
    CmdBL = Array("一覧プレ", "タックシールプレ", "選択フォーム", "編集フォーム")

    '------ボタンのキャプション名とレポート名・フォーム名の
    '      ハッシュテーブル
    Set CapRepo = New Dictionary
    With CapRepo
        .Add CmdBL(0), "R:レポート1"
        .Add CmdBL(1), "R:レポート2"
        .Add CmdBL(2), "F:フォーム1"
        .Add CmdBL(3), "F:フォーム2"
    End With

Private Sub bu3_Click() の追加

ボタン「編集フォーム」をクリックしたときのアクションを記述しています。

'---------------------------------------
'
Private Sub bu3_Click()

    Call ChangeObj(CapRepo(Me.bu3.Caption))

End Sub

copy

Private Sub Form_Load()
    Dim Ret             As Variant
    Dim SetValue        As Long
    Dim OpenObj         As Variant
    Dim I               As Long
    On Error Resume Next

    '------Win32API関数を使ってアクセスを最小化します
    CloseWindow Application.hWndAccessApp

    '------現在の設定値を取得
    SetValue = GetWindowLong(Me.hWnd, GWL_STYLE)

    '------最小化ボタンを無効
    SetValue = SetValue And Not WS_MINIMIZEBOX

    '------設定値をセット
    SetWindowLong Me.hWnd, GWL_STYLE, SetValue

    '------単位変換の変換率の計算
    TP = TwipPixel

    '------ボタンのキャプションリスト
    CmdBL = Array("一覧プレ", "タックシールプレ", "選択フォーム", "編集フォーム")

    '------ボタンのキャプションをセット
    For I = 0 To UBound(CmdBL)
        Me("bu" & I).Caption = CmdBL(I)
    Next I

    '------ボタンのキャプション名とレポート名・フォーム名の
    '      ハッシュテーブル
    Set CapRepo = New Dictionary
    With CapRepo
        .Add CmdBL(0), "R:レポート1"
        .Add CmdBL(1), "R:レポート2"
        .Add CmdBL(2), "F:フォーム1"
        .Add CmdBL(3), "F:フォーム2"
    End With

    '------初期値
    curReportName = ""
    curFormName = ""
    TargetList = ""
    AllList = ""

    '------子フォームの原点
    X = 0
    Y = Me.bu閉じる.Height + Me.bu閉じる.Top * 2

    '------子フォームの大きさ
    Call ChildFormSize

    '------フォームの OpenArgs プロパティを使用します
    If IsNull(Me.OpenArgs) Then
        Call ChangeObj(CapRepo("選択フォーム"))
    Else
        Call ChangeObj(Me.OpenArgs)
    End If

End Sub
'---------------------------------------
'
Private Sub bu3_Click()

    Call ChangeObj(CapRepo(Me.bu3.Caption))

End Sub

ACCESS 名簿を考えてみる 3

今回の概要

フォーム「 入力 」

フォームの構成

コード

フォーム「 フォーム2 」

フォームの構成

コード

フォーム「 ベース 」

コード

Private Sub bu3_Click() の追加

フォーム「入力」

フォーム「フォーム2 」

フォーム「ベース」