どの方法が良いのだろう
あるQAで、以下の条件があったとして、フォームを作るには・・・
テーブル「Tチーム」
テーブル「T試合」
テーブル「T選手」
テーブル「T出場」
つまり、自チームの選手「T選手」が、どの対戦相手の時に出場していたか・・・・
フォームのイメージとしては、
・「T試合」を登録/修正時に、
・「T選手」の全選手を表示して(100くらい)
チェックボックス形式で入力操作したい。(「T出場」を同時に作りこみたい)
フィールド | 型 等々 |
---|---|
チームID | オートナンバ (主キー) |
チーム名 | テキスト |
テーブル「T試合」
フィールド | 型 等々 |
---|---|
試合ID | オートナンバ (主キー) |
試合日 | 日付/時刻 |
天候 | テキスト |
相手チーム | 長整数 「Tチーム」のチームID |
試合場所 | テキスト |
テーブル「T選手」
フィールド | 型 等々 |
---|---|
選手ID | オートナンバ (主キー) |
選手名 | テキスト |
よみ | テキスト |
テーブル「T出場」
フィールド | 型 等々 |
---|---|
an | オートナンバ (主キー) |
試合ID | 長整数 「T試合」の試合ID |
選手ID | 長整数 「T選手」の選手ID |
つまり、自チームの選手「T選手」が、どの対戦相手の時に出場していたか・・・・
フォームのイメージとしては、
・「T試合」を登録/修正時に、
・「T選手」の全選手を表示して(100くらい)
チェックボックス形式で入力操作したい。(「T出場」を同時に作りこみたい)
ザッと考えてみたフォームは9つ
1)帳票フォームに帳票サブフォーム(F1M/F1S)


2)単票に2つの帳票サブフォーム(F2M/F2S1/F2S2)


3)単票に10個のサブフォーム(F3M/F3S)(あ行、か行・・・毎にサブフォーム)


4)単票に6個のサブフォーム(F4M/F4S)(1つのサブフォームでは20人表示)


5)上記フォームのワークテーブル使用バージョン(F5M/F5S)


6)単票に多数の非連結チェックボックス(F6M)


上記フォームのVBA記述量削減・操作限定バージョン(F6M2)


7)上記フォームの表示変更バージョン(F7M)

8)単票にタブコントロール配置(F8M)(タブページで、あ行、か行・・・)
実際に操作するのは、多数の非連結チェックボックス



9)単票に単票サブフォーム(F9M/F9S) (ワークテーブル使用)


で、6)を回答。
回答からブログの記事にするまで、いろいろ勉強させられました。
2007 で作成して、2003 / 2000 形式に変換して確認しているわけですが・・・
これに手間取っていました。
※ 2000 には、Form_Undo がない
※ サブフォームで組み込んだフォームの Form_Open / Form_Load は、
2000 の場合は連続して実行されない時がある。
特に分ける必要がない場合には、Form_Open 1つに記述した方が無難
※ サブフォームコントロールで、SourceObject にフォームを設定したタイミングで
LinkMasterFields / LinkChildFields が自動設定される時がある。
私が知らなかっただけなのかも・・・・
今回の記事はチョッくら長いです。
テーブル「T選手」内の「よみ」は、必ず設定されているものとして記述していきます。
また、「T試合」を表示しているフォームでは、削除操作がないものとしてします。
なので、フォームでの「削除の許可」は「いいえ」としておきます。
これは、「T試合」のレコードを削除した際、「T出場」のレコードをどういう方法で削除するか・・・
自力で?
使った事ないけど、リレーションシップで「連鎖削除」を設定しておく?
今回、削除については触れないという事で・・・・
1)帳票フォームに帳票サブフォーム(F1M/F1S)


メインのフォーム「F1M」は「T試合」を元にフォームウィザードで「試合ID」以外を表示するように。
「試合ID」はオートナンバなので、表示はいらないでしょう・・・という事で。
サブフォームがフォームのイベントを取得できるように、プロパティ「コード保持」を「はい」に。
サブフォームになる「F1S」は、フォームデザインで作っていきます。
レコードソースを SELECT T選手.選手ID, T選手.選手名, T選手.よみ FROM T選手 ORDER BY T選手.よみ;
ヘッダ部分に非表示のテキストボックス「txt1」
これの用途は、親で選ばれた試合に出場した選手の「選手ID」が「,」(カンマ)区切りで・・・
詳細部分には、
・チェックボックス「ck」
このチェックボックスでは、コントロールソースを使用しますがVBAで設定するので、そのままに。
ラベル部分はいらないので削除
タブストップは「いいえ」
・そのチェックボックスを覆う形で(前面側に)、コマンドボタン「btn1」
背景スタイルを透明
このボタンがクリックされた=チェックボックスの チェック 切り換えと解釈
タブ移動順を先頭に
・選手名用テキストボックス「選手名」
ラベル部分はいらないので削除
コントロールソースを 選手名 に設定
念のため、タブストップを「いいえ」
このテキストボックスは、チェックボックスにくっ付いているラベルの様な動きにします。
チェックボックスにチェックが入っていたら、背景色を変更します。
この変更に、条件付き書式を使いますが、VBAで設定するので、そのままに。
フォームは帳票フォームにして、
・レコードセレクタ「いいえ」
・移動ボタン「いいえ」
・スクロール「垂直のみ」
・追加/削除/更新の許可は、すべて「いいえ」
フォームのデザインはこれで終わりです。
見栄え上のことですが、チェックボックスが多数並ぶのでチェックだけでは分かりづらい???
ということで、チェックしたら選手名のところの背景色を変更しましょう・・・という事にしました。
VBAを記述していくわけですが、処理概要をまず。
親で「試合ID」が変化したら「T出場」から、その試合に出ていた「選手ID」を求めます。
この【親で「試合ID」が変化したら】は、親のレコード移動時を検知するようにします。
その求まった「選手ID」を「,」(カンマ)区切りで羅列したものを「txt1」に設定します。
チェックボックスでは、その設定された「txt1」内に、自レコードの「選手ID」があるか判別表示します。
チェックボックスのコントロールソース記述で
=IIF(InStr([txt1],"," & [選手ID] & ",")>0,True,False)
これと同じような判別で、テキストボックス「選手名」の背景色を条件付き書式で変更します。
式が、InStr([txt1],"," & [選手ID] & ",")>0 で、背景色を RGB(255, 240, 240)
チェックボックスがクリック(実際にはコマンドボタン「btn1」のクリック)されたら、
「txt1」に自レコードの「選手ID」があれば、その部分を削除、なければ新たに追加・・・
本来、文字列の操作ですが、面倒だったので Dictionary で選手IDを管理することに。
この変更のタイミングで、「T出場」のレコードを操作することに。
また、テキストボックス「選手名」にフォーカス移動(実際にはマウスのクリック)された場合は、
フォーカスを「btn1」に移し、「btn1」がクリックされた時の処理を・・・・
これにより、テキストボックス「選手名」はチェックボックス「ck」のラベル的動きに・・・・???
記述したのは以下
Private Const EVENT_PROCEDURE As String = "[EVENT PROCEDURE]"
Dim WithEvents frm As Form
Dim dic As Object
Private Sub Form_Open(Cancel As Integer)
On Error Resume Next
Set frm = Me.Parent
If (frm Is Nothing) Then
Cancel = True
Exit Sub
End If
Set dic = CreateObject("Scripting.Dictionary")
frm.OnCurrent = EVENT_PROCEDURE
Me.ck.ControlSource = _
"=IIF(InStr([txt1],"","" & [選手ID] & "","")>0,True,False)"
With Me.選手名.FormatConditions
.Delete
With .Add(acExpression, , "InStr([txt1],"","" & [選手ID] & "","")>0")
.BackColor = RGB(255, 240, 240)
End With
End With
End Sub
Private Sub Txt1ValueSet()
If (dic.Count > 0) Then
Me.txt1 = "," & Join(dic.Keys, ",") & ","
Else
Me.txt1 = ",,"
End If
End Sub
Private Sub frm_Current()
Dim sSql As String
Dim rs As DAO.Recordset
dic.RemoveAll
If (Not IsNull(frm.試合ID)) Then
sSql = "SELECT * FROM T出場 WHERE 試合ID = " & frm.試合ID & ";"
Set rs = CurrentDb.OpenRecordset(sSql)
While (Not rs.EOF)
dic.Item(rs("選手ID").Value) = Null
rs.MoveNext
Wend
rs.Close
Set rs = Nothing
End If
Call Txt1ValueSet
End Sub
Private Sub btn1_Click()
Dim sSql As String
Dim i As Long
If (IsNull(frm.試合ID)) Then Exit Sub
i = Me.選手ID
If (dic.Exists(i)) Then
sSql = "DELETE * FROM T出場 WHERE 試合ID = " _
& frm.試合ID & " AND 選手ID = " & i & ";"
CurrentDb.Execute sSql
dic.Remove i
Else
sSql = "INSERT INTO T出場(試合ID, 選手ID) VALUES (" _
& frm.試合ID & "," & i & ");"
CurrentDb.Execute sSql
dic.Item(i) = Null
End If
Call Txt1ValueSet
End Sub
Private Sub 選手名_Enter()
Me.btn1.SetFocus
btn1_Click
End Sub
Private Sub Form_Close()
Set frm = Nothing
Set dic = Nothing
End Sub
Dim WithEvents frm As Form
Dim dic As Object
Private Sub Form_Open(Cancel As Integer)
On Error Resume Next
Set frm = Me.Parent
If (frm Is Nothing) Then
Cancel = True
Exit Sub
End If
Set dic = CreateObject("Scripting.Dictionary")
frm.OnCurrent = EVENT_PROCEDURE
Me.ck.ControlSource = _
"=IIF(InStr([txt1],"","" & [選手ID] & "","")>0,True,False)"
With Me.選手名.FormatConditions
.Delete
With .Add(acExpression, , "InStr([txt1],"","" & [選手ID] & "","")>0")
.BackColor = RGB(255, 240, 240)
End With
End With
End Sub
Private Sub Txt1ValueSet()
If (dic.Count > 0) Then
Me.txt1 = "," & Join(dic.Keys, ",") & ","
Else
Me.txt1 = ",,"
End If
End Sub
Private Sub frm_Current()
Dim sSql As String
Dim rs As DAO.Recordset
dic.RemoveAll
If (Not IsNull(frm.試合ID)) Then
sSql = "SELECT * FROM T出場 WHERE 試合ID = " & frm.試合ID & ";"
Set rs = CurrentDb.OpenRecordset(sSql)
While (Not rs.EOF)
dic.Item(rs("選手ID").Value) = Null
rs.MoveNext
Wend
rs.Close
Set rs = Nothing
End If
Call Txt1ValueSet
End Sub
Private Sub btn1_Click()
Dim sSql As String
Dim i As Long
If (IsNull(frm.試合ID)) Then Exit Sub
i = Me.選手ID
If (dic.Exists(i)) Then
sSql = "DELETE * FROM T出場 WHERE 試合ID = " _
& frm.試合ID & " AND 選手ID = " & i & ";"
CurrentDb.Execute sSql
dic.Remove i
Else
sSql = "INSERT INTO T出場(試合ID, 選手ID) VALUES (" _
& frm.試合ID & "," & i & ");"
CurrentDb.Execute sSql
dic.Item(i) = Null
End If
Call Txt1ValueSet
End Sub
Private Sub 選手名_Enter()
Me.btn1.SetFocus
btn1_Click
End Sub
Private Sub Form_Close()
Set frm = Nothing
Set dic = Nothing
End Sub
で、出来上がった「F1S」を「F1M」のフッタ部分にドラッグ&ドロップします。
この時、「F1M」は単票に変更されますが、再度帳票に変更して終了。
(このメイン/サブ構成は自己責任で・・・・)
この処理で、親の更新後処理で表示し直す必要があるのでは・・・・・については、
更新後処理で「試合ID」が変化するケースは、新規登録された場合だけになるので、
元々その試合には出場している選手は存在しないので、取得し直すことは不要になります。
(親が新規行にレコード移動した際に Dictionary はクリアされているので)
(以降のフォームでは、親の更新後処理を検知するものもあります)
その他の部分で、疑問を持たれる方がいるかも・・・・・ん、どの部分??
選手IDを Dictionary で管理しているのなら、チェックボックス、条件付き書式のところで
Dictionary にあるか・・・チェックすれば、非表示の「txt1」は不要なのでは・・・・・
これ用に上記を変更するとしたら以下の様になります。(変更する部分のみ)
Private Function DicChk(v As Variant) As Boolean
DicChk = dic.Exists(v.Value)
End Function
Private Sub Form_Open(Cancel As Integer)
On Error Resume Next
Set frm = Me.Parent
If (frm Is Nothing) Then
Cancel = True
Exit Sub
End If
Set dic = CreateObject("Scripting.Dictionary")
frm.OnCurrent = EVENT_PROCEDURE
Me.ck.ControlSource = "=DicChk([選手ID])"
With Me.選手名.FormatConditions
.Delete
With .Add(acExpression, , "DicChk([選手ID])")
.BackColor = RGB(255, 240, 240)
End With
End With
End Sub
Private Sub Txt1ValueSet()
Me.Recalc
End Sub
これでも動作するんですが、変更したら毎回 Me.Recalc が必要になって、チラつきが大きくなるんですね。DicChk = dic.Exists(v.Value)
End Function
Private Sub Form_Open(Cancel As Integer)
On Error Resume Next
Set frm = Me.Parent
If (frm Is Nothing) Then
Cancel = True
Exit Sub
End If
Set dic = CreateObject("Scripting.Dictionary")
frm.OnCurrent = EVENT_PROCEDURE
Me.ck.ControlSource = "=DicChk([選手ID])"
With Me.選手名.FormatConditions
.Delete
With .Add(acExpression, , "DicChk([選手ID])")
.BackColor = RGB(255, 240, 240)
End With
End With
End Sub
Private Sub Txt1ValueSet()
Me.Recalc
End Sub
Me.Recalc しないと、初期表示のまま何も変化がありません。
コントロールソースや条件付き書式の式で指定したものに変更がないと、変化しないようです。
なので、その指定した部分([txt1]が変更された・・・)を使うようにしてました。
でも、チラつきについては同じなのかなぁ・・・・雰囲気は違うみたいなんだけどなぁ・・・・
Private Sub Txt1ValueSet()
Me.Painting = False
Me.Recalc
Me.Painting = True
End Sub
と、Painting で挟んだらチョッと改善されたけど・・・・Me.Painting = False
Me.Recalc
Me.Painting = True
End Sub
あと、記述に不満というか・・・・ Sub の関数を呼ぶ時、私は Call を付けて記述しています。
以下の部分には Call が付いているものと思ってください。(記述漏れでした)
Private Sub 選手名_Enter()
Me.btn1.SetFocus
Call btn1_Click
End Sub
Me.btn1.SetFocus
Call btn1_Click
End Sub
2)単票に2つの帳票サブフォーム(F2M/F2S1/F2S2)


このフォームでは、帳票+帳票のメイン/サブフォーム構成ではなく、一般的に使える構成になると思います。
大元の非連結の単票フォーム(F2M)に、
サブフォームコントロール「FSUB1」として「T試合」用の帳票サブフォーム(F2S1)、
サブフォームコントロール「FSUB2」として「T選手」用の帳票サブフォーム(F2S2)を配置します。
フォーム「F2S2」は、前のフォーム「F1S」をコピーして中の記述をチョッとだけいじります。
(フォーム「F2S1」と連動するように)
フォーム「F2S1」は新しく「T試合」を元にフォームウィザードを使って、まず、単票として作成し、
(フィールドを縦に並べたかっただけ)それを帳票フォームに変更します。
削除は処理対象にしないので、削除の許可は「いいえ」に、「コード保持」は「はい」に。
親フォーム「F2M」は Form_Load 時、サブフォーム「F2S1」の情報を「F2S2」へ通知するだけ。
タイミング的には、親が Load された時点で、サブフォーム側の初期処理は終わっているようなので・・・
(「F2S2」単独で「F2S1」情報を取ろうとした時、「F2S1」が居なかったりする???)
「F2S2」では親からもらった「F2S1」情報を元に、「F2S1」のレコード移動時イベントを検知するように・・・
親では、「F2S2」の設定が終わったら、「F2S1」を Requery してレコード移動時イベントを作ってやる。
親フォーム「F2M」に記述したのは
Private Sub Form_Load()
With Me.FSUB1
Call Me.FSUB2.Form.frm_Set(.Form)
.Form.Requery
End With
End Sub
With Me.FSUB1
Call Me.FSUB2.Form.frm_Set(.Form)
.Form.Requery
End With
End Sub
フォーム「F2S1」にはVBA記述なし。単独で起動されても問題ないかなぁ・・・
フォーム「F2S2」は「F1S」をコピーしたものだったので、変更した箇所を以下に
(「F1S」の Form_Open 部分を 2つの関数に分けただけです)
Private Sub Form_Open(Cancel As Integer)
On Error Resume Next
If (Me.Parent.Name = "") Then
Cancel = True
Exit Sub
End If
Set dic = CreateObject("Scripting.Dictionary")
End Sub
Public Sub frm_Set(fm As Form)
Set frm = fm
frm.OnCurrent = EVENT_PROCEDURE
Me.ck.ControlSource = _
"=IIF(InStr([txt1],"","" & [選手ID] & "","")>0,True,False)"
With Me.選手名.FormatConditions
.Delete
With .Add(acExpression, , "InStr([txt1],"","" & [選手ID] & "","")>0")
.BackColor = RGB(255, 240, 240)
End With
End With
End Sub
On Error Resume Next
If (Me.Parent.Name = "") Then
Cancel = True
Exit Sub
End If
Set dic = CreateObject("Scripting.Dictionary")
End Sub
Public Sub frm_Set(fm As Form)
Set frm = fm
frm.OnCurrent = EVENT_PROCEDURE
Me.ck.ControlSource = _
"=IIF(InStr([txt1],"","" & [選手ID] & "","")>0,True,False)"
With Me.選手名.FormatConditions
.Delete
With .Add(acExpression, , "InStr([txt1],"","" & [選手ID] & "","")>0")
.BackColor = RGB(255, 240, 240)
End With
End With
End Sub
サブフォームとして組み込まれていなければ、起動しない様に
親からフォーム「F2S1」(「T試合」を表示している帳票フォーム)のフォームを教えてもらう。
で、レコード移動時を検知できるように・・・・
3)単票に10個のサブフォーム(F3M/F3S)(あ行、か行・・・毎にサブフォーム)


このフォームでは、あ行、か行・・・別で表示しましょう・・・・というもの。
フォーム「F1M」を「F3M」としてコピーし、フッタ部分のサブフォームコントロールを削除。
フッタ部分の領域をなしにして、詳細部分を広げます。
その詳細部分にサブフォームコントロール「FSUB0」~「FSUB9」の10個配置します。
このサブフォームコントロールに、前作ったフォーム「F1S」を入れて、行別表示に仕立て上げます。
処理を少し変更するので、「F1S」を「F3S」としてコピーします。
サブフォームコントロールのソースオブジェクトは空欄にしておきます。
これは1つのフォーム「F3S」を使い回しする為の1つの方法だと思っています。
FSUB0 では「あ行」を表示して・・・・ FSUB1 では「か行」を表示して・・・・って指示したかったので
この指示に、親フォームのタグを連絡用に使い、ソースオブジェクトに「F3S」を設定
「F3S」では、情報を親のタグから入手し、指示に従った表示をするように。
サブフォームコントロールは、10人分を表示できる高さにデザインで設定しておきます。
親フォーム「F3M」に記述したのは以下
Private Const sFilter As String = _
"[あ-お]*,[か-ご]*,[さ-ぞ]*,[た-ど]*,[な-の]*," _
& "[は-ぽ]*,[ま-も]*,[や-よ]*,[ら-ろ]*,[わ-ん]*"
Private Sub Form_Load()
Dim sAry() As String
Dim i As Long
sAry = Split(sFilter, ",")
For i = 0 To UBound(sAry)
Me.Tag = sAry(i)
Me("FSUB" & i).SourceObject = "F3S"
Next
End Sub
"[あ-お]*,[か-ご]*,[さ-ぞ]*,[た-ど]*,[な-の]*," _
& "[は-ぽ]*,[ま-も]*,[や-よ]*,[ら-ろ]*,[わ-ん]*"
Private Sub Form_Load()
Dim sAry() As String
Dim i As Long
sAry = Split(sFilter, ",")
For i = 0 To UBound(sAry)
Me.Tag = sAry(i)
Me("FSUB" & i).SourceObject = "F3S"
Next
End Sub
子フォーム「F3S」として「F1S」から変更した部分は以下
Private Const sSource As String = "SELECT * FROM T選手 WHERE よみ Like '%1' ORDER BY よみ;"
Private Const EVENT_PROCEDURE As String = "[EVENT PROCEDURE]"
Dim WithEvents frm As Form
Dim sFilter As String
Dim dic As Object
Private Sub Form_Open(Cancel As Integer)
On Error Resume Next
Set frm = Me.Parent
If (frm Is Nothing) Then
Cancel = True
Exit Sub
End If
Set dic = CreateObject("Scripting.Dictionary")
frm.OnCurrent = EVENT_PROCEDURE
sFilter = frm.Tag
Me.RecordSource = Replace(sSource, "%1", sFilter)
If (Me.Recordset.RecordCount <= 10) Then Me.ScrollBars = 0
Me.ck.ControlSource = _
"=IIF(InStr([txt1],"","" & [選手ID] & "","")>0,True,False)"
With Me.選手名.FormatConditions
.Delete
With .Add(acExpression, , "InStr([txt1],"","" & [選手ID] & "","")>0")
.BackColor = RGB(255, 240, 240)
End With
End With
End Sub
Private Sub frm_Current()
Dim sSql As String
Dim rs As DAO.Recordset
dic.RemoveAll
If (Not IsNull(frm.試合ID)) Then
sSql = "SELECT * FROM T出場 WHERE 試合ID = " & frm.試合ID _
& " AND 選手ID IN (SELECT 選手ID FROM T選手 WHERE よみ LIKE '" _
& sFilter & "');"
Set rs = CurrentDb.OpenRecordset(sSql)
While (Not rs.EOF)
dic.Item(rs("選手ID").Value) = Null
rs.MoveNext
Wend
rs.Close
Set rs = Nothing
End If
Call Txt1ValueSet
End Sub
Private Const EVENT_PROCEDURE As String = "[EVENT PROCEDURE]"
Dim WithEvents frm As Form
Dim sFilter As String
Dim dic As Object
Private Sub Form_Open(Cancel As Integer)
On Error Resume Next
Set frm = Me.Parent
If (frm Is Nothing) Then
Cancel = True
Exit Sub
End If
Set dic = CreateObject("Scripting.Dictionary")
frm.OnCurrent = EVENT_PROCEDURE
sFilter = frm.Tag
Me.RecordSource = Replace(sSource, "%1", sFilter)
If (Me.Recordset.RecordCount <= 10) Then Me.ScrollBars = 0
Me.ck.ControlSource = _
"=IIF(InStr([txt1],"","" & [選手ID] & "","")>0,True,False)"
With Me.選手名.FormatConditions
.Delete
With .Add(acExpression, , "InStr([txt1],"","" & [選手ID] & "","")>0")
.BackColor = RGB(255, 240, 240)
End With
End With
End Sub
Private Sub frm_Current()
Dim sSql As String
Dim rs As DAO.Recordset
dic.RemoveAll
If (Not IsNull(frm.試合ID)) Then
sSql = "SELECT * FROM T出場 WHERE 試合ID = " & frm.試合ID _
& " AND 選手ID IN (SELECT 選手ID FROM T選手 WHERE よみ LIKE '" _
& sFilter & "');"
Set rs = CurrentDb.OpenRecordset(sSql)
While (Not rs.EOF)
dic.Item(rs("選手ID").Value) = Null
rs.MoveNext
Wend
rs.Close
Set rs = Nothing
End If
Call Txt1ValueSet
End Sub
If (Me.Recordset.RecordCount <= 10) Then Me.ScrollBars = 0
この記述ですが、表示選手が10人に満たない場合、2007 ではスクロールバー表示はありませんでした。でも、2000 / 2003 では、常に縦のスクロールバーが表示される。
サブフォームコントロール側では10人分表示できるように設定しているので、
共通の処理として、表示対象が10人以下ならスクロールバーを表示しない様に・・・・
表示を見てみましたが、何のための空白部分か・・・何か違和感ありありです。
あ行、か行 の表示はやめて、20人単位で表示しましょうか・・・・っていうのが次(F4M/F4S)に
4)単票に6個のサブフォーム(F4M/F4S)(1つのサブフォームでは20人表示)


このフォームでは、20人単位でサブフォームとして表示しましょう・・・というもの
基本的な考え方/処理は前の(F3M/F3S)と同じなので、「F3M」を「F4M」、「F3S」を「F4S」にコピー
前のフォームでは、 よみ Like '%1' の %1 にあたる文字列を指定していましたが、
今回のフォームでは 選手ID IN (%1) の %1 にあたる文字列を指定するようにします。
フォーム「F4M」で、サブフォームコントロールを「FSUB1」~「FSUB6」の6つに
選手20人を表示できるようにしておきます。
処理の概要としては、選手を「よみ」順で20人単位でサブフォームを設定していきますが、
最後の「FSUB6」だけは20人を超えても作り続けるようにします。
その時に、もしかして・・・人数が多すぎて・・・・・タグの文字数制限に引っ掛かるようになるかも・・・
(その時にはその時で別の手段を使うように変更しますか・・・・)
親フォーム「F4M」に記述したのは以下
Private Sub Form_Load()
Dim sSql As String
Dim rs As DAO.Recordset
Dim i As Long
Dim iFSUB As Long
sSql = "SELECT * FROM T選手 ORDER BY よみ;"
Set rs = CurrentDb.OpenRecordset(sSql)
iFSUB = 0
i = 0
sSql = ""
While (Not rs.EOF)
sSql = sSql & "," & rs("選手ID")
i = i + 1
If (i >= 20) Then
If (iFSUB < 5) Then
iFSUB = iFSUB + 1
Me.Tag = Mid(sSql, 2)
Me("FSUB" & iFSUB).SourceObject = "F4S"
sSql = ""
End If
i = 0
End If
rs.MoveNext
Wend
rs.Close
Set rs = Nothing
If (Len(sSql) > 0) Then
Me.Tag = Mid(sSql, 2)
Me("FSUB" & iFSUB + 1).SourceObject = "F4S"
End If
End Sub
Dim sSql As String
Dim rs As DAO.Recordset
Dim i As Long
Dim iFSUB As Long
sSql = "SELECT * FROM T選手 ORDER BY よみ;"
Set rs = CurrentDb.OpenRecordset(sSql)
iFSUB = 0
i = 0
sSql = ""
While (Not rs.EOF)
sSql = sSql & "," & rs("選手ID")
i = i + 1
If (i >= 20) Then
If (iFSUB < 5) Then
iFSUB = iFSUB + 1
Me.Tag = Mid(sSql, 2)
Me("FSUB" & iFSUB).SourceObject = "F4S"
sSql = ""
End If
i = 0
End If
rs.MoveNext
Wend
rs.Close
Set rs = Nothing
If (Len(sSql) > 0) Then
Me.Tag = Mid(sSql, 2)
Me("FSUB" & iFSUB + 1).SourceObject = "F4S"
End If
End Sub
子フォーム「F4S」で「F3S」から変更した部分は以下
Private Const sSource As String = "SELECT * FROM T選手 WHERE 選手ID IN (%1) ORDER BY よみ;"
Private Const EVENT_PROCEDURE As String = "[EVENT PROCEDURE]"
Dim WithEvents frm As Form
Dim sFilter As String
Dim dic As Object
Private Sub Form_Open(Cancel As Integer)
On Error Resume Next
Set frm = Me.Parent
If (frm Is Nothing) Then
Cancel = True
Exit Sub
End If
Set dic = CreateObject("Scripting.Dictionary")
frm.OnCurrent = EVENT_PROCEDURE
sFilter = frm.Tag
Me.RecordSource = Replace(sSource, "%1", sFilter)
If (Me.Recordset.RecordCount <= 20) Then Me.ScrollBars = 0
Me.ck.ControlSource = _
"=IIF(InStr([txt1],"","" & [選手ID] & "","")>0,True,False)"
With Me.選手名.FormatConditions
.Delete
With .Add(acExpression, , "InStr([txt1],"","" & [選手ID] & "","")>0")
.BackColor = RGB(255, 240, 240)
End With
End With
End Sub
Private Sub frm_Current()
Dim sSql As String
Dim rs As DAO.Recordset
dic.RemoveAll
If (Not IsNull(frm.試合ID)) Then
sSql = "SELECT * FROM T出場 WHERE 試合ID = " & frm.試合ID _
& " AND 選手ID IN (" & sFilter & ");"
Set rs = CurrentDb.OpenRecordset(sSql)
While (Not rs.EOF)
dic.Item(rs("選手ID").Value) = Null
rs.MoveNext
Wend
rs.Close
Set rs = Nothing
End If
Call Txt1ValueSet
End Sub
Private Const EVENT_PROCEDURE As String = "[EVENT PROCEDURE]"
Dim WithEvents frm As Form
Dim sFilter As String
Dim dic As Object
Private Sub Form_Open(Cancel As Integer)
On Error Resume Next
Set frm = Me.Parent
If (frm Is Nothing) Then
Cancel = True
Exit Sub
End If
Set dic = CreateObject("Scripting.Dictionary")
frm.OnCurrent = EVENT_PROCEDURE
sFilter = frm.Tag
Me.RecordSource = Replace(sSource, "%1", sFilter)
If (Me.Recordset.RecordCount <= 20) Then Me.ScrollBars = 0
Me.ck.ControlSource = _
"=IIF(InStr([txt1],"","" & [選手ID] & "","")>0,True,False)"
With Me.選手名.FormatConditions
.Delete
With .Add(acExpression, , "InStr([txt1],"","" & [選手ID] & "","")>0")
.BackColor = RGB(255, 240, 240)
End With
End With
End Sub
Private Sub frm_Current()
Dim sSql As String
Dim rs As DAO.Recordset
dic.RemoveAll
If (Not IsNull(frm.試合ID)) Then
sSql = "SELECT * FROM T出場 WHERE 試合ID = " & frm.試合ID _
& " AND 選手ID IN (" & sFilter & ");"
Set rs = CurrentDb.OpenRecordset(sSql)
While (Not rs.EOF)
dic.Item(rs("選手ID").Value) = Null
rs.MoveNext
Wend
rs.Close
Set rs = Nothing
End If
Call Txt1ValueSet
End Sub
ここまでのフォームでは、帳票フォームで非連結のチェックボックスを使ってきました。
この方法からチョッと離れて考えてみよう・・・・ということで、以降、違う方法になっていきます。
5)上記フォームのワークテーブル使用バージョン(F5M/F5S)


前回のフォーム構成を使って、サブフォーム側のレコードソースをワークテーブルにしてみます。
テーブル「Tワーク出場5」として
フィールド | 型 等々 |
---|---|
an | オートナンバ (主キー) |
試合ID | 長整数 「T試合」の試合ID |
選手ID | 長整数 「T選手」の選手ID |
ck | Yes/No型 |
1試合分のデータだけを扱うようにします。
試合ID は不要?なのかもしれません。
データを「Tワーク出場5」「T出場」間でやり取りしやすかったので・・・
(これが後で問題に・・・・・・・・・後述)
フォーム「F4M」を「F5M」としてコピーします。
サブフォームの個数、20人までの表示は前と変わりません。
変わるのは、ワークテーブル「Tワーク出場5」から本テーブル「T出場」へ戻すタイミングを作ること・・・・
更新用のボタン「btn1」と、
戻す(本テーブル「T出場」からワークテーブル「Tワーク出場5」へ再展開)用のボタン「btn2」を配置
サブフォーム用のフォームは「F4S」を「F5S」としてコピーします。
レコードソースは表示する際に書き換えるものの、
標準で「Tワーク出場5」と「T選手」とで選手名を表示できるようにしたものを設定しておきます。
ヘッダ部にあった「txt1」、詳細部分でチェックボックスを覆っていた「btn1」は削除します。
チェックボックス「ck」のコントロールソースに「ck」を設定し、タブストップを「はい」に。
チェックボックスをクリックして更新するので、フォームの「更新の許可」だけ「はい」に変更。
処理の概要を。
メインフォーム「F5M」では、Load 時、「Tワーク出場5」に全選手の選手IDを作成します。
「T選手」の「よみ」順で20人ずつサブフォームに割り当てていきます。
(「FSUB1」~順にソースオブジェクトにサブフォームを割り当てていきます)
レコード移動時に、「Tワーク出場5」の 試合ID と ck を更新します。
更新後処理では、新規で試合ID が割り当てられることがあるので、レコード移動時の処理をもう一度。
更新ボタン「btn1」がクリックされたら、「Tワーク出場5」を元にその試合に該当するものを作り直します。
戻すボタン「btn2」がクリックされたら、その試合にあったデータを「Tワーク出場5」に作り直します。
ここで、新規登録(試合IDがNull)の場合、「Tワーク出場5」の試合ID は 0 に設定。
サブフォーム側では、「Tワーク出場5」に対して「ck」を設定していきます。
設定する際、親に配置した更新ボタン「btn1」の文字色を変更するようにします。
親フォーム「F5M」に記述したのは以下
Private Sub Form_Load()
Dim sSql As String
Dim rs As DAO.Recordset
Dim i As Long
Dim iFSUB As Long
sSql = "DELETE * FROM Tワーク出場5;"
CurrentDb.Execute sSql
sSql = "INSERT INTO Tワーク出場5(選手ID) " _
& "SELECT 選手ID FROM T選手;"
CurrentDb.Execute sSql
sSql = "SELECT * FROM T選手 ORDER BY よみ;"
Set rs = CurrentDb.OpenRecordset(sSql)
iFSUB = 0
i = 0
sSql = ""
While (Not rs.EOF)
sSql = sSql & "," & rs("選手ID")
i = i + 1
If (i >= 20) Then
If (iFSUB < 5) Then
iFSUB = iFSUB + 1
Me.Tag = Mid(sSql, 2)
With Me("FSUB" & iFSUB)
.SourceObject = "F5S"
.LinkMasterFields = ""
.LinkChildFields = ""
End With
sSql = ""
End If
i = 0
End If
rs.MoveNext
Wend
rs.Close
Set rs = Nothing
If (Len(sSql) > 0) Then
Me.Tag = Mid(sSql, 2)
With Me("FSUB" & iFSUB + 1)
.SourceObject = "F5S"
.LinkMasterFields = ""
.LinkChildFields = ""
End With
End If
End Sub
Private Sub FSUBrequery()
Dim i As Long
For i = 1 To 6
With Me("FSUB" & i)
If (Len(.SourceObject) = 0) Then Exit For
.Form.Requery
End With
Next
Me.btn1.ForeColor = RGB(0, 0, 0)
End Sub
Private Sub Form_Current()
Dim sSql As String
sSql = "UPDATE Tワーク出場5 SET 試合ID = " & Nz(Me.試合ID, 0) _
& ", ck = False;"
CurrentDb.Execute sSql
sSql = "UPDATE Tワーク出場5 INNER JOIN T出場 ON " _
& "Tワーク出場5.試合ID = T出場.試合ID AND Tワーク出場5.選手ID = T出場.選手ID " _
& "SET Tワーク出場5.ck = True;"
CurrentDb.Execute sSql
Call FSUBrequery
End Sub
Private Sub Form_AfterUpdate()
Call Form_Current
End Sub
Private Sub btn1_Click()
Dim sSql As String
If (Me.btn1.ForeColor = RGB(0, 0, 0)) Then Exit Sub
sSql = "DELETE * FROM T出場 WHERE 試合ID = " & Me.試合ID & ";"
CurrentDb.Execute sSql
sSql = "INSERT INTO T出場(試合ID, 選手ID) " _
& "SELECT 試合ID, 選手ID FROM Tワーク出場5 WHERE ck = True;"
CurrentDb.Execute sSql
Call FSUBrequery
End Sub
Private Sub btn2_Click()
Dim sSql As String
If (Me.btn1.ForeColor = RGB(0, 0, 0)) Then Exit Sub
sSql = "UPDATE Tワーク出場5 SET ck = False;"
CurrentDb.Execute sSql
sSql = "UPDATE Tワーク出場5 INNER JOIN T出場 ON " _
& "Tワーク出場5.試合ID = T出場.試合ID AND Tワーク出場5.選手ID = T出場.選手ID " _
& "SET Tワーク出場5.ck = True;"
CurrentDb.Execute sSql
Call FSUBrequery
End Sub
Private Sub Form_Close()
Dim sSql As String
sSql = "DELETE * FROM Tワーク出場5;"
CurrentDb.Execute sSql
End Sub
Dim sSql As String
Dim rs As DAO.Recordset
Dim i As Long
Dim iFSUB As Long
sSql = "DELETE * FROM Tワーク出場5;"
CurrentDb.Execute sSql
sSql = "INSERT INTO Tワーク出場5(選手ID) " _
& "SELECT 選手ID FROM T選手;"
CurrentDb.Execute sSql
sSql = "SELECT * FROM T選手 ORDER BY よみ;"
Set rs = CurrentDb.OpenRecordset(sSql)
iFSUB = 0
i = 0
sSql = ""
While (Not rs.EOF)
sSql = sSql & "," & rs("選手ID")
i = i + 1
If (i >= 20) Then
If (iFSUB < 5) Then
iFSUB = iFSUB + 1
Me.Tag = Mid(sSql, 2)
With Me("FSUB" & iFSUB)
.SourceObject = "F5S"
.LinkMasterFields = ""
.LinkChildFields = ""
End With
sSql = ""
End If
i = 0
End If
rs.MoveNext
Wend
rs.Close
Set rs = Nothing
If (Len(sSql) > 0) Then
Me.Tag = Mid(sSql, 2)
With Me("FSUB" & iFSUB + 1)
.SourceObject = "F5S"
.LinkMasterFields = ""
.LinkChildFields = ""
End With
End If
End Sub
Private Sub FSUBrequery()
Dim i As Long
For i = 1 To 6
With Me("FSUB" & i)
If (Len(.SourceObject) = 0) Then Exit For
.Form.Requery
End With
Next
Me.btn1.ForeColor = RGB(0, 0, 0)
End Sub
Private Sub Form_Current()
Dim sSql As String
sSql = "UPDATE Tワーク出場5 SET 試合ID = " & Nz(Me.試合ID, 0) _
& ", ck = False;"
CurrentDb.Execute sSql
sSql = "UPDATE Tワーク出場5 INNER JOIN T出場 ON " _
& "Tワーク出場5.試合ID = T出場.試合ID AND Tワーク出場5.選手ID = T出場.選手ID " _
& "SET Tワーク出場5.ck = True;"
CurrentDb.Execute sSql
Call FSUBrequery
End Sub
Private Sub Form_AfterUpdate()
Call Form_Current
End Sub
Private Sub btn1_Click()
Dim sSql As String
If (Me.btn1.ForeColor = RGB(0, 0, 0)) Then Exit Sub
sSql = "DELETE * FROM T出場 WHERE 試合ID = " & Me.試合ID & ";"
CurrentDb.Execute sSql
sSql = "INSERT INTO T出場(試合ID, 選手ID) " _
& "SELECT 試合ID, 選手ID FROM Tワーク出場5 WHERE ck = True;"
CurrentDb.Execute sSql
Call FSUBrequery
End Sub
Private Sub btn2_Click()
Dim sSql As String
If (Me.btn1.ForeColor = RGB(0, 0, 0)) Then Exit Sub
sSql = "UPDATE Tワーク出場5 SET ck = False;"
CurrentDb.Execute sSql
sSql = "UPDATE Tワーク出場5 INNER JOIN T出場 ON " _
& "Tワーク出場5.試合ID = T出場.試合ID AND Tワーク出場5.選手ID = T出場.選手ID " _
& "SET Tワーク出場5.ck = True;"
CurrentDb.Execute sSql
Call FSUBrequery
End Sub
Private Sub Form_Close()
Dim sSql As String
sSql = "DELETE * FROM Tワーク出場5;"
CurrentDb.Execute sSql
End Sub
子フォーム「F5S」に記述したのは以下
Private Const sSource As String = _
"SELECT Q1.*, Q2.選手名 FROM Tワーク出場5 AS Q1 INNER JOIN T選手 AS Q2 " _
& "ON Q1.選手ID = Q2.選手ID WHERE Q1.選手ID IN (%1) ORDER BY Q2.よみ;"
Dim frm As Form
Private Sub Form_Open(Cancel As Integer)
On Error Resume Next
Set frm = Me.Parent
If (frm Is Nothing) Then
Cancel = True
Exit Sub
End If
Me.RecordSource = Replace(sSource, "%1", frm.Tag)
If (Me.Recordset.RecordCount <= 20) Then Me.ScrollBars = 0
With Me.選手名.FormatConditions
.Delete
With .Add(acExpression, , "[ck]=True")
.BackColor = RGB(255, 240, 240)
End With
End With
End Sub
Private Sub Form_Dirty(Cancel As Integer)
If (Me.試合ID = 0) Then Cancel = True
End Sub
Private Sub ck_Click()
frm.btn1.ForeColor = RGB(255, 0, 0)
End Sub
Private Sub 選手名_Enter()
Me.ck.SetFocus
If (Me.試合ID <> 0) Then
Me.ck = Not Me.ck
Call ck_Click
End If
End Sub
Private Sub Form_Close()
Set frm = Nothing
End Sub
"SELECT Q1.*, Q2.選手名 FROM Tワーク出場5 AS Q1 INNER JOIN T選手 AS Q2 " _
& "ON Q1.選手ID = Q2.選手ID WHERE Q1.選手ID IN (%1) ORDER BY Q2.よみ;"
Dim frm As Form
Private Sub Form_Open(Cancel As Integer)
On Error Resume Next
Set frm = Me.Parent
If (frm Is Nothing) Then
Cancel = True
Exit Sub
End If
Me.RecordSource = Replace(sSource, "%1", frm.Tag)
If (Me.Recordset.RecordCount <= 20) Then Me.ScrollBars = 0
With Me.選手名.FormatConditions
.Delete
With .Add(acExpression, , "[ck]=True")
.BackColor = RGB(255, 240, 240)
End With
End With
End Sub
Private Sub Form_Dirty(Cancel As Integer)
If (Me.試合ID = 0) Then Cancel = True
End Sub
Private Sub ck_Click()
frm.btn1.ForeColor = RGB(255, 0, 0)
End Sub
Private Sub 選手名_Enter()
Me.ck.SetFocus
If (Me.試合ID <> 0) Then
Me.ck = Not Me.ck
Call ck_Click
End If
End Sub
Private Sub Form_Close()
Set frm = Nothing
End Sub
上記で動いているようですが、この1つ前の記述では、
新規の試合を入力しようとした場合、サブフォーム部分に何も表示されない現象が発生。
1つ前の記述と言うと、サブフォームを設定する際の記述になりますが
(以下の黄色い部分の記述がありませんでした)
Private Sub Form_Load()
Dim sSql As String
Dim rs As DAO.Recordset
Dim i As Long
Dim iFSUB As Long
sSql = "DELETE * FROM Tワーク出場5;"
CurrentDb.Execute sSql
sSql = "INSERT INTO Tワーク出場5(選手ID) " _
& "SELECT 選手ID FROM T選手;"
CurrentDb.Execute sSql
sSql = "SELECT * FROM T選手 ORDER BY よみ;"
Set rs = CurrentDb.OpenRecordset(sSql)
iFSUB = 0
i = 0
sSql = ""
While (Not rs.EOF)
sSql = sSql & "," & rs("選手ID")
i = i + 1
If (i >= 20) Then
If (iFSUB < 5) Then
iFSUB = iFSUB + 1
Me.Tag = Mid(sSql, 2)
With Me("FSUB" & iFSUB)
.SourceObject = "F5S"
.LinkMasterFields = ""
.LinkChildFields = ""
End With
sSql = ""
End If
i = 0
End If
rs.MoveNext
Wend
rs.Close
Set rs = Nothing
If (Len(sSql) > 0) Then
Me.Tag = Mid(sSql, 2)
With Me("FSUB" & iFSUB + 1)
.SourceObject = "F5S"
.LinkMasterFields = ""
.LinkChildFields = ""
End With
End If
End Sub
Dim sSql As String
Dim rs As DAO.Recordset
Dim i As Long
Dim iFSUB As Long
sSql = "DELETE * FROM Tワーク出場5;"
CurrentDb.Execute sSql
sSql = "INSERT INTO Tワーク出場5(選手ID) " _
& "SELECT 選手ID FROM T選手;"
CurrentDb.Execute sSql
sSql = "SELECT * FROM T選手 ORDER BY よみ;"
Set rs = CurrentDb.OpenRecordset(sSql)
iFSUB = 0
i = 0
sSql = ""
While (Not rs.EOF)
sSql = sSql & "," & rs("選手ID")
i = i + 1
If (i >= 20) Then
If (iFSUB < 5) Then
iFSUB = iFSUB + 1
Me.Tag = Mid(sSql, 2)
With Me("FSUB" & iFSUB)
.SourceObject = "F5S"
.LinkMasterFields = ""
.LinkChildFields = ""
End With
sSql = ""
End If
i = 0
End If
rs.MoveNext
Wend
rs.Close
Set rs = Nothing
If (Len(sSql) > 0) Then
Me.Tag = Mid(sSql, 2)
With Me("FSUB" & iFSUB + 1)
.SourceObject = "F5S"
.LinkMasterFields = ""
.LinkChildFields = ""
End With
End If
End Sub
.SourceObject = "F5S"
でサブフォームの処理が走り始めるわけですが、Form_Open が呼ばれる前に LinkMasterFields / LinkChildFields が "試合ID" に自動設定。
Form_Open の初めの処理で、LinkMasterFields / LinkChildFields をクリア(空文字設定)しても、
その後の、RecordSource 設定直後にまた、LinkMasterFields / LinkChildFields が "試合ID" に。
リレーションシップは設定していないし・・・・
ま、確かに、親の「試合ID」は主キーに設定していましたが・・・・
あ、ルックアップは設定していたかな・・・
Access さんのどこかのオプション設定で回避できるのかもしれないけど、その設定を強要する???
あれ、や・・・、名前の自動修正?? これってそのDBを限定できたっっっっっかも・・・(未確認)
でも、親側で SourceObject 設定後に、LinkMasterFields / LinkChildFields をクリアすれば
動くようなので、この記述を採用しました。
主キーと同じフィールド名があったから??・・・・次回から気をつけよう。
6)単票に多数の非連結チェックボックス(F6M)


これが回答に使った、そのものになります。
元にするフォーム「F6M_BASE」を作っておきます。(「T試合」を元にした単票フォーム)
「F5M」をコピーしてサブフォーム部分を削除、VBA記述を全削除したものにしておきます。
また、
・「登録」ボタンが押された時に登録する
・・・・ということが抜けていたので、それに対応するように、登録ボタン「btn1」を配置。
チェックボックスを作成していきますが、必要人数以上のチェックボックスを不可視で作っておいて、
表示する時に必要な分だけ、可視(Visible=True)に変更します。
チェックボックス名の命名規則として、「"ck" & 連番」とします。
(100くらい、ということだったので "ck1" ~ "ck120" )
手作業で多数のチェックボックスを作成して名前を変更・・・
これ面倒なので、VBAで作成します。
1列20個で、計120個(6列分)のチェックボックスと、それにひっつくラベル
このラベル部分に選手名を表示するようにします。
標準モジュール「M6Make」を用意しました。
チェックボックスを追加する対象のフォーム「F6M_BASE」を、一旦「F6M_BASE_」にコピーして、
作り終わったら「F6M」に名称を変更 という内容になってます。
Private Const sFname As String = "F6M_BASE"
Private Const sFnew As String = "F6M"
Private Const IPX As Long = 567
Private Const iRowCount As Long = 20
Public Const iM6Count As Long = 120
Public Sub M6MakeProc()
Dim i As Long
Dim sN As String, sNc As String
Dim iRow As Long, iCol As Long
On Error Resume Next
sN = sFname & "_"
DoCmd.DeleteObject acForm, sN
DoCmd.CopyObject , sN, acForm, sFname
DoCmd.OpenForm sN, acDesign
With Forms(sN)
iRow = IPX * 1
iCol = IPX * 0.27
For i = 0 To iM6Count - 1
With CreateControl(sN, acCheckBox, acDetail)
sNc = "ck" & i + 1
.Name = sNc
.Top = iRow + (i Mod iRowCount) * IPX * 0.5
.Left = (i \ iRowCount) * IPX * 3.2 + iCol
.Width = IPX * 0.4
.Height = IPX * 0.4
.DefaultValue = "0"
.TabStop = False
.Visible = False
End With
With CreateControl(sN, acLabel, acDetail, sNc)
.Top = iRow + (i Mod iRowCount) * IPX * 0.5
.Left = (i \ iRowCount) * IPX * 3.2 + (IPX * 0.42) + iCol
.Width = IPX * 2.6
.Height = IPX * 0.42
.BorderStyle = 1
.BorderWidth = 1
.BorderColor = RGB(0, 0, 0)
.BackStyle = 0
.BackColor = RGB(255, 240, 240)
End With
Next
End With
DoCmd.Close acForm, sN, acSaveYes
DoCmd.DeleteObject acForm, sFnew
DoCmd.Rename sFnew, acForm, sN
End Sub
Private Const sFnew As String = "F6M"
Private Const IPX As Long = 567
Private Const iRowCount As Long = 20
Public Const iM6Count As Long = 120
Public Sub M6MakeProc()
Dim i As Long
Dim sN As String, sNc As String
Dim iRow As Long, iCol As Long
On Error Resume Next
sN = sFname & "_"
DoCmd.DeleteObject acForm, sN
DoCmd.CopyObject , sN, acForm, sFname
DoCmd.OpenForm sN, acDesign
With Forms(sN)
iRow = IPX * 1
iCol = IPX * 0.27
For i = 0 To iM6Count - 1
With CreateControl(sN, acCheckBox, acDetail)
sNc = "ck" & i + 1
.Name = sNc
.Top = iRow + (i Mod iRowCount) * IPX * 0.5
.Left = (i \ iRowCount) * IPX * 3.2 + iCol
.Width = IPX * 0.4
.Height = IPX * 0.4
.DefaultValue = "0"
.TabStop = False
.Visible = False
End With
With CreateControl(sN, acLabel, acDetail, sNc)
.Top = iRow + (i Mod iRowCount) * IPX * 0.5
.Left = (i \ iRowCount) * IPX * 3.2 + (IPX * 0.42) + iCol
.Width = IPX * 2.6
.Height = IPX * 0.42
.BorderStyle = 1
.BorderWidth = 1
.BorderColor = RGB(0, 0, 0)
.BackStyle = 0
.BackColor = RGB(255, 240, 240)
End With
Next
End With
DoCmd.Close acForm, sN, acSaveYes
DoCmd.DeleteObject acForm, sFnew
DoCmd.Rename sFnew, acForm, sN
End Sub
フォーム「F6M」にVBAを記述していきますが、概要をまず。
・チェックボックスクリック時
「T試合」の新規レコードであったら、見た目チェックを無効とするようにします
チェックボックスは非連結なので、変更してもレコード移動等のタイミングは分かりません。
なので、編集状態にしておくことで、レコード移動のタイミングを検知することが出来るようになります。
そこで、「天候」を同じ値で設定して編集状態に・・・
チェックボックスの変更状態を更新します。
・フォームが起動された時
「T選手」から選手情報をチェックボックスに割り当てていきます。
割り当てたチェックボックスのラベルに選手名を、+可視に
チェックボックスの Tag に、選手ID を登録しておきます。
これにより、クリックされた時、簡単に選手を特定できるようになります。
・レコード移動時
レコード移動によって「試合ID」が変化するので、その時の「試合ID」で
「T出場」にある選手を抽出し、チェックボックスを変更していきます。
・更新前
登録ボタン「btn1」クリックでのみ更新/登録できるようにするので、
意図しないタイミングでの更新はできない様に、常に Cancel = True とします
・取り消し時(2000では動かない)
チェックボックスを初期状態に戻し、レコード移動時に取得した選手情報でチェックボックスを再設定
・登録ボタン
「T試合」への登録チェックが必要であればこのタイミングで
一度、更新前処理を無効としてレコードを登録します。
「T出場」に対して、チェックボックスの状態を反映します。
dicOld は、レコード移動時に取得したその試合での選手情報で、
チェックボックスでの変更状況は dicNew にて。
レコード移動直後は、dicOld dicNew は同じ内容となっています。
チェックボックスの操作により、dicOld dicNew の差分で DELETE したり、INSERT したりします。
登録操作後、dicOld dicNew の内容を同じにするため、レコード移動時の処理を。
記述したVBAは以下
Dim dic As Object ' どの選手にどのチェックボックスを割り当てたか
Dim dicOld As Object ' 編集前の選手割り当て状況 (初期では dicOld = dicNew)
Dim dicNew As Object ' いじっていた選手割り当て状況
Private Function ChkClick()
If (IsNull(Me.試合ID)) Then
Me.ActiveControl = Not Me.ActiveControl
Exit Function
End If
Me.天候 = Me.天候 '編集状態にしたいため
With Me.ActiveControl
If (.Value) Then
.Controls(0).BackStyle = 1
dicNew.Item(CLng(.Tag)) = Null
Else
.Controls(0).BackStyle = 0
dicNew.Remove CLng(.Tag)
End If
End With
End Function
Private Sub Form_Load()
Dim sSql As String
Dim rs As DAO.Recordset
Dim i As Long
Dim sN As String
Set dic = CreateObject("Scripting.Dictionary")
Set dicOld = CreateObject("Scripting.Dictionary")
Set dicNew = CreateObject("Scripting.Dictionary")
sSql = "SELECT * FROM T選手 ORDER BY よみ;"
Set rs = CurrentDb.OpenRecordset(sSql)
i = 0
Do While (Not rs.EOF)
i = i + 1
If (i > iM6Count) Then Exit Do
sN = "ck" & i
dic.Item(rs("選手ID").Value) = sN
With Me(sN)
.Value = False
.Tag = rs("選手ID")
With .Controls(0)
.Caption = rs("選手名")
.BackStyle = 0
End With
.OnClick = "=ChkClick()"
.Visible = True
End With
rs.MoveNext
Loop
rs.Close
Set rs = Nothing
End Sub
Private Sub Form_Current()
Dim sSql As String
Dim rs As DAO.Recordset
Dim i As Long
Me.Painting = False
For i = 1 To iM6Count
With Me("ck" & i)
If (Not .Visible) Then Exit For
.Value = False
.Controls(0).BackStyle = 0
End With
Next
dicOld.RemoveAll
dicNew.RemoveAll
sSql = "SELECT * FROM T出場 WHERE 試合ID = " & Nz(Me.試合ID, 0) & ";"
Set rs = CurrentDb.OpenRecordset(sSql)
While (Not rs.EOF)
i = rs("選手ID")
dicOld.Item(i) = Null
dicNew.Item(i) = Null
With Me(dic.Item(i))
.Value = True
.Controls(0).BackStyle = 1
End With
rs.MoveNext
Wend
rs.Close
Set rs = Nothing
Me.Painting = True
End Sub
Private Sub Form_BeforeUpdate(Cancel As Integer)
Cancel = True
MsgBox "修正したら登録ボタンで確定", vbCritical
End Sub
Private Sub Form_Undo(Cancel As Integer)
Dim v As Variant
Dim i As Long
Me.Painting = False
For i = 1 To iM6Count
With Me("ck" & i)
If (Not .Visible) Then Exit For
.Value = False
.Controls(0).BackStyle = 0
End With
Next
dicNew.RemoveAll
If (dicOld.Count > 0) Then
For Each v In dicOld.Keys
dicNew.Item(v) = Null
With Me(dic.Item(v))
.Value = True
.Controls(0).BackStyle = 1
End With
Next
End If
Me.Painting = True
End Sub
Private Sub btn1_Click()
Dim sSql As String
Dim sS As String
Dim v As Variant
If (Not Me.Dirty) Then Exit Sub
' 試合日など入力チェックをするのなら、この場所で
'
sS = Me.BeforeUpdate
Me.BeforeUpdate = ""
Me.Dirty = False
Me.BeforeUpdate = sS
If (dicOld.Count > 0) Then
For Each v In dicOld.Keys
If (Not dicNew.Exists(v)) Then
sSql = "DELETE * FROM T出場 WHERE 試合ID = " & Me.試合ID _
& " AND 選手ID = " & v & ";"
CurrentDb.Execute sSql
End If
Next
End If
If (dicNew.Count > 0) Then
For Each v In dicNew.Keys
If (Not dicOld.Exists(v)) Then
sSql = "INSERT INTO T出場(試合ID, 選手ID) VALUES (" _
& Me.試合ID & "," & v & ");"
CurrentDb.Execute sSql
End If
Next
End If
Call Form_Current
End Sub
Private Sub Form_Close()
Set dic = Nothing
Set dicOld = Nothing
Set dicNew = Nothing
End Sub
Dim dicOld As Object ' 編集前の選手割り当て状況 (初期では dicOld = dicNew)
Dim dicNew As Object ' いじっていた選手割り当て状況
Private Function ChkClick()
If (IsNull(Me.試合ID)) Then
Me.ActiveControl = Not Me.ActiveControl
Exit Function
End If
Me.天候 = Me.天候 '編集状態にしたいため
With Me.ActiveControl
If (.Value) Then
.Controls(0).BackStyle = 1
dicNew.Item(CLng(.Tag)) = Null
Else
.Controls(0).BackStyle = 0
dicNew.Remove CLng(.Tag)
End If
End With
End Function
Private Sub Form_Load()
Dim sSql As String
Dim rs As DAO.Recordset
Dim i As Long
Dim sN As String
Set dic = CreateObject("Scripting.Dictionary")
Set dicOld = CreateObject("Scripting.Dictionary")
Set dicNew = CreateObject("Scripting.Dictionary")
sSql = "SELECT * FROM T選手 ORDER BY よみ;"
Set rs = CurrentDb.OpenRecordset(sSql)
i = 0
Do While (Not rs.EOF)
i = i + 1
If (i > iM6Count) Then Exit Do
sN = "ck" & i
dic.Item(rs("選手ID").Value) = sN
With Me(sN)
.Value = False
.Tag = rs("選手ID")
With .Controls(0)
.Caption = rs("選手名")
.BackStyle = 0
End With
.OnClick = "=ChkClick()"
.Visible = True
End With
rs.MoveNext
Loop
rs.Close
Set rs = Nothing
End Sub
Private Sub Form_Current()
Dim sSql As String
Dim rs As DAO.Recordset
Dim i As Long
Me.Painting = False
For i = 1 To iM6Count
With Me("ck" & i)
If (Not .Visible) Then Exit For
.Value = False
.Controls(0).BackStyle = 0
End With
Next
dicOld.RemoveAll
dicNew.RemoveAll
sSql = "SELECT * FROM T出場 WHERE 試合ID = " & Nz(Me.試合ID, 0) & ";"
Set rs = CurrentDb.OpenRecordset(sSql)
While (Not rs.EOF)
i = rs("選手ID")
dicOld.Item(i) = Null
dicNew.Item(i) = Null
With Me(dic.Item(i))
.Value = True
.Controls(0).BackStyle = 1
End With
rs.MoveNext
Wend
rs.Close
Set rs = Nothing
Me.Painting = True
End Sub
Private Sub Form_BeforeUpdate(Cancel As Integer)
Cancel = True
MsgBox "修正したら登録ボタンで確定", vbCritical
End Sub
Private Sub Form_Undo(Cancel As Integer)
Dim v As Variant
Dim i As Long
Me.Painting = False
For i = 1 To iM6Count
With Me("ck" & i)
If (Not .Visible) Then Exit For
.Value = False
.Controls(0).BackStyle = 0
End With
Next
dicNew.RemoveAll
If (dicOld.Count > 0) Then
For Each v In dicOld.Keys
dicNew.Item(v) = Null
With Me(dic.Item(v))
.Value = True
.Controls(0).BackStyle = 1
End With
Next
End If
Me.Painting = True
End Sub
Private Sub btn1_Click()
Dim sSql As String
Dim sS As String
Dim v As Variant
If (Not Me.Dirty) Then Exit Sub
' 試合日など入力チェックをするのなら、この場所で
'
sS = Me.BeforeUpdate
Me.BeforeUpdate = ""
Me.Dirty = False
Me.BeforeUpdate = sS
If (dicOld.Count > 0) Then
For Each v In dicOld.Keys
If (Not dicNew.Exists(v)) Then
sSql = "DELETE * FROM T出場 WHERE 試合ID = " & Me.試合ID _
& " AND 選手ID = " & v & ";"
CurrentDb.Execute sSql
End If
Next
End If
If (dicNew.Count > 0) Then
For Each v In dicNew.Keys
If (Not dicOld.Exists(v)) Then
sSql = "INSERT INTO T出場(試合ID, 選手ID) VALUES (" _
& Me.試合ID & "," & v & ");"
CurrentDb.Execute sSql
End If
Next
End If
Call Form_Current
End Sub
Private Sub Form_Close()
Set dic = Nothing
Set dicOld = Nothing
Set dicNew = Nothing
End Sub
上記フォームのVBA記述量削減・操作限定バージョン(F6M2)


このフォームでは、「F6M」の処理/操作を限定して、極力VBA記述を少なくしたものになります。
限定したのは、
・「T試合」の新規登録時のみ
・選手を追加したらフォームの手直しが必要
・この用途以外にチェックボックスがない事
チェックボックスは非連結で自由に配置しますが、以下の設定が必要です。
・チェックボックスの「タグ」には、「選手ID」を設定しておく
・チェックボックスのラベルには、その選手の「選手名」を表示するように
また、チェックボックス名は何でも構わない、個数も限定しない。
で、これを確認するフォームを作成するのですが、手修正も面倒なので・・・・
標準モジュール「M6M62」を用意しました。
(フォーム「F6M」を元に、上記条件に修正していくものです)
Public Sub M6toM62()
Dim sSql As String
Dim rs As DAO.Recordset
Dim i As Long
Const sSrcFname As String = "F6M"
Const sFname As String = "F6M2"
On Error Resume Next
DoCmd.DeleteObject acForm, sFname
DoCmd.CopyObject , sFname, acForm, sSrcFname
DoCmd.OpenForm sFname, acDesign
With Forms(sFname)
.Caption = sFname
.DataEntry = True
sSql = "SELECT * FROM T選手 ORDER BY よみ;"
Set rs = CurrentDb.OpenRecordset(sSql)
i = 0
While (Not rs.EOF)
i = i + 1
With .Controls("ck" & i)
.Visible = True
.Tag = rs("選手ID")
.Controls(0).Caption = rs("選手名")
End With
rs.MoveNext
Wend
rs.Close
Set rs = Nothing
End With
End Sub
Dim sSql As String
Dim rs As DAO.Recordset
Dim i As Long
Const sSrcFname As String = "F6M"
Const sFname As String = "F6M2"
On Error Resume Next
DoCmd.DeleteObject acForm, sFname
DoCmd.CopyObject , sFname, acForm, sSrcFname
DoCmd.OpenForm sFname, acDesign
With Forms(sFname)
.Caption = sFname
.DataEntry = True
sSql = "SELECT * FROM T選手 ORDER BY よみ;"
Set rs = CurrentDb.OpenRecordset(sSql)
i = 0
While (Not rs.EOF)
i = i + 1
With .Controls("ck" & i)
.Visible = True
.Tag = rs("選手ID")
.Controls(0).Caption = rs("選手名")
End With
rs.MoveNext
Wend
rs.Close
Set rs = Nothing
End With
End Sub
で、割り当てられていない不要なチェックボックスを削除するなりします。
(3列削除しましたが、配置はそのままにしたのが現状の「F6M2」です)
フォーム「F6M2」に記述したのは以下
Private Sub Form_Current()
Dim ctl As Control
For Each ctl In Me.Controls
With ctl
If (.ControlType = acCheckBox) Then
.Value = False
End If
End With
Next
End Sub
Private Sub Form_BeforeUpdate(Cancel As Integer)
Cancel = True
MsgBox "登録ボタンで確定", vbCritical
End Sub
Private Sub btn1_Click()
Dim sSql As String
Dim sS As String
Dim ctl As Control
If (Not Me.Dirty) Then Exit Sub
' 試合日など入力チェックをするのなら、この場所で
'
sS = Me.BeforeUpdate
Me.BeforeUpdate = ""
Me.Dirty = False
Me.BeforeUpdate = sS
For Each ctl In Me.Controls
With ctl
If (.ControlType = acCheckBox And Len(.Tag) > 0) Then
If (.Value) Then
sSql = "INSERT INTO T出場(試合ID, 選手ID) VALUES (" _
& Me.試合ID & "," & .Tag & ");"
CurrentDb.Execute sSql
End If
End If
End With
Next
Me.Requery
End Sub
Dim ctl As Control
For Each ctl In Me.Controls
With ctl
If (.ControlType = acCheckBox) Then
.Value = False
End If
End With
Next
End Sub
Private Sub Form_BeforeUpdate(Cancel As Integer)
Cancel = True
MsgBox "登録ボタンで確定", vbCritical
End Sub
Private Sub btn1_Click()
Dim sSql As String
Dim sS As String
Dim ctl As Control
If (Not Me.Dirty) Then Exit Sub
' 試合日など入力チェックをするのなら、この場所で
'
sS = Me.BeforeUpdate
Me.BeforeUpdate = ""
Me.Dirty = False
Me.BeforeUpdate = sS
For Each ctl In Me.Controls
With ctl
If (.ControlType = acCheckBox And Len(.Tag) > 0) Then
If (.Value) Then
sSql = "INSERT INTO T出場(試合ID, 選手ID) VALUES (" _
& Me.試合ID & "," & .Tag & ");"
CurrentDb.Execute sSql
End If
End If
End With
Next
Me.Requery
End Sub
新規登録時に、まずチェックボックスのチェックを外しておきます。
「登録」ボタンがクリックされた時に、チェックがあるものを探し出し、レコードを追加します。
チェック自体は「T試合」のものを入力していない状態でも、自由に ON / OFF できます。
なお、VBA記述を少なくするために、ラベル部分の背景色は変更していません。
登録ボタン「btn1」の最後で、Me.Requery しているのは、
新規登録を連続して行った場合、前のレコードに戻れたような気がして・・・・
もし、戻ったとした場合、チェックボックスの表示を処理できない・・・・
なので、Me.Requery して、新規レコードのみにするように・・・・
7)上記フォームの表示変更バージョン(F7M)

このフォームでは、「よみ」順に割り当てていく際に、あ行、か行・・・・行が変わったら1つ空けましょう。
フォーム「F6M」を「F7M」でコピーし、以下の記述を追加/修正します。
Private Function GyouNum(sSrc As String) As Long
Select Case True
Case sSrc Like "[あ-お]*": GyouNum = 0
Case sSrc Like "[か-ご]*": GyouNum = 1
Case sSrc Like "[さ-ぞ]*": GyouNum = 2
Case sSrc Like "[た-ど]*": GyouNum = 3
Case sSrc Like "[な-の]*": GyouNum = 4
Case sSrc Like "[は-ぽ]*": GyouNum = 5
Case sSrc Like "[ま-も]*": GyouNum = 6
Case sSrc Like "[や-よ]*": GyouNum = 7
Case sSrc Like "[ら-ろ]*": GyouNum = 8
Case sSrc Like "[わ-ん]*": GyouNum = 9
Case Else: GyouNum = 20
End Select
End Function
Private Sub Form_Load()
Dim sSql As String
Dim rs As DAO.Recordset
Dim iGyou As Long, iGyouNew As Long
Dim i As Long
Dim sN As String
Set dic = CreateObject("Scripting.Dictionary")
Set dicOld = CreateObject("Scripting.Dictionary")
Set dicNew = CreateObject("Scripting.Dictionary")
sSql = "SELECT * FROM T選手 ORDER BY よみ;"
Set rs = CurrentDb.OpenRecordset(sSql)
i = 0
Do While (Not rs.EOF)
iGyouNew = GyouNum(rs("よみ"))
If (i = 0) Then iGyou = iGyouNew
i = i + 1
If (iGyou <> iGyouNew) Then i = i + 1
iGyou = iGyouNew
If (i > iM6Count) Then Exit Do
sN = "ck" & i
dic.Item(rs("選手ID").Value) = sN
Select Case True
Case sSrc Like "[あ-お]*": GyouNum = 0
Case sSrc Like "[か-ご]*": GyouNum = 1
Case sSrc Like "[さ-ぞ]*": GyouNum = 2
Case sSrc Like "[た-ど]*": GyouNum = 3
Case sSrc Like "[な-の]*": GyouNum = 4
Case sSrc Like "[は-ぽ]*": GyouNum = 5
Case sSrc Like "[ま-も]*": GyouNum = 6
Case sSrc Like "[や-よ]*": GyouNum = 7
Case sSrc Like "[ら-ろ]*": GyouNum = 8
Case sSrc Like "[わ-ん]*": GyouNum = 9
Case Else: GyouNum = 20
End Select
End Function
Private Sub Form_Load()
Dim sSql As String
Dim rs As DAO.Recordset
Dim iGyou As Long, iGyouNew As Long
Dim i As Long
Dim sN As String
Set dic = CreateObject("Scripting.Dictionary")
Set dicOld = CreateObject("Scripting.Dictionary")
Set dicNew = CreateObject("Scripting.Dictionary")
sSql = "SELECT * FROM T選手 ORDER BY よみ;"
Set rs = CurrentDb.OpenRecordset(sSql)
i = 0
Do While (Not rs.EOF)
iGyouNew = GyouNum(rs("よみ"))
If (i = 0) Then iGyou = iGyouNew
i = i + 1
If (iGyou <> iGyouNew) Then i = i + 1
iGyou = iGyouNew
If (i > iM6Count) Then Exit Do
sN = "ck" & i
dic.Item(rs("選手ID").Value) = sN
また、チェックボックスをクリアする以下記述2か所を変更します。
For i = 1 To iM6Count
With Me("ck" & i)
If (Not .Visible) Then Exit For
.Value = False
.Controls(0).BackStyle = 0
End With
Next
をWith Me("ck" & i)
If (Not .Visible) Then Exit For
.Value = False
.Controls(0).BackStyle = 0
End With
Next
Dim v As Variant
For Each v In dic.Items
With Me(v)
.Value = False
.Controls(0).BackStyle = 0
End With
Next
に。For Each v In dic.Items
With Me(v)
.Value = False
.Controls(0).BackStyle = 0
End With
Next
これは、チェックボックスは連続して Visible = True になっているわけではないので・・・・
(フォーム「F6M」でも、下側記述で OK です)
8)単票にタブコントロール配置(F8M)(タブページで、あ行、か行・・・)
実際に操作するのは、多数の非連結チェックボックス



このフォームでは、多数のチェックボックスをタブコントロールを使って、
あ行、か行・・・・をタブページで分けて表示しましょう・・・・というものです。
タブページには、非表示のチェックボックスを各30個配置しておきます。
(表示する時に使う分だけ可視に変更するのは、今まで通りです)
タブページ0には、標題「あ」、チェックボックス「ck1」~「ck30」
タブページ1には、標題「か」、チェックボックス「ck101」~「ck130」
・・・・
タブページ9には、標題「わ」、チェックボックス「ck901」~「ck930」
という規則を設けます。
また、今回はチェックボックスは横から採番しましょう・・・・
フォーム「F8M_BASE」(フォーム「F6M_BASE」をコピー)を用意し、
標準モジュール「M8Make」に用意した M8MakeProc を実行すると雰囲気フォームが出来上がります。
それをきれいに配置し直して保存します。
Private Const sFname As String = "F8M_BASE"
Private Const sFnew As String = "F8M"
Private Const IPX As Long = 567
Private Const iColCount As Long = 3
Public Const iM8Count As Long = 30
Public Sub M8MakeProc()
Dim i As Long, j As Long
Dim sN As String, sNc As String
Dim iRow As Long, iCol As Long
Dim ctl As Control
Dim sAry() As String
Const sPageCaption As String = "あ,か,さ,た,な,は,ま,や,ら,わ"
On Error Resume Next
sN = sFname & "_"
DoCmd.DeleteObject acForm, sN
DoCmd.CopyObject , sN, acForm, sFname
DoCmd.OpenForm sN, acDesign
With CreateControl(sN, acTabCtl, acDetail)
.Name = "tb0"
sAry = Split(sPageCaption, ",")
While (.Controls.Count <= UBound(sAry))
Call CreateControl(sN, acPage, acDetail, .Name)
Wend
For i = UBound(sAry) To 0 Step -1
With .Controls(i)
.Name = "tbp" & i
.Caption = sAry(i)
iRow = IPX * 1.5
iCol = IPX * 0.5
For j = 0 To iM8Count - 1
With CreateControl(sN, acCheckBox, acDetail, .Name)
sNc = "ck" & i * 100 + j + 1
.Name = sNc
.Top = (j \ iColCount) * IPX * 0.5 + iRow
.Left = (j Mod iColCount) * IPX * 5 + iCol
.Width = IPX * 0.4
.Height = IPX * 0.4
.DefaultValue = "0"
.TabStop = False
.Visible = False
End With
With CreateControl(sN, acLabel, acDetail, sNc)
.Top = (j \ iColCount) * IPX * 0.5 + iRow
.Left = (j Mod iColCount) * IPX * 5 + (IPX * 0.42) + iCol
.Width = IPX * 2.6
.Height = IPX * 0.42
.BorderStyle = 1
.BorderWidth = 1
.BorderColor = RGB(0, 0, 0)
.BackStyle = 0
.BackColor = RGB(255, 240, 240)
End With
Next
End With
Next
.Top = IPX * 1.5
.Left = IPX * 0.5
.Width = IPX * 14
.Height = IPX * 6
End With
DoCmd.Close acForm, sN, acSaveYes
DoCmd.DeleteObject acForm, sFnew
DoCmd.Rename sFnew, acForm, sN
DoCmd.OpenForm sFnew, acDesign
End Sub
Private Const sFnew As String = "F8M"
Private Const IPX As Long = 567
Private Const iColCount As Long = 3
Public Const iM8Count As Long = 30
Public Sub M8MakeProc()
Dim i As Long, j As Long
Dim sN As String, sNc As String
Dim iRow As Long, iCol As Long
Dim ctl As Control
Dim sAry() As String
Const sPageCaption As String = "あ,か,さ,た,な,は,ま,や,ら,わ"
On Error Resume Next
sN = sFname & "_"
DoCmd.DeleteObject acForm, sN
DoCmd.CopyObject , sN, acForm, sFname
DoCmd.OpenForm sN, acDesign
With CreateControl(sN, acTabCtl, acDetail)
.Name = "tb0"
sAry = Split(sPageCaption, ",")
While (.Controls.Count <= UBound(sAry))
Call CreateControl(sN, acPage, acDetail, .Name)
Wend
For i = UBound(sAry) To 0 Step -1
With .Controls(i)
.Name = "tbp" & i
.Caption = sAry(i)
iRow = IPX * 1.5
iCol = IPX * 0.5
For j = 0 To iM8Count - 1
With CreateControl(sN, acCheckBox, acDetail, .Name)
sNc = "ck" & i * 100 + j + 1
.Name = sNc
.Top = (j \ iColCount) * IPX * 0.5 + iRow
.Left = (j Mod iColCount) * IPX * 5 + iCol
.Width = IPX * 0.4
.Height = IPX * 0.4
.DefaultValue = "0"
.TabStop = False
.Visible = False
End With
With CreateControl(sN, acLabel, acDetail, sNc)
.Top = (j \ iColCount) * IPX * 0.5 + iRow
.Left = (j Mod iColCount) * IPX * 5 + (IPX * 0.42) + iCol
.Width = IPX * 2.6
.Height = IPX * 0.42
.BorderStyle = 1
.BorderWidth = 1
.BorderColor = RGB(0, 0, 0)
.BackStyle = 0
.BackColor = RGB(255, 240, 240)
End With
Next
End With
Next
.Top = IPX * 1.5
.Left = IPX * 0.5
.Width = IPX * 14
.Height = IPX * 6
End With
DoCmd.Close acForm, sN, acSaveYes
DoCmd.DeleteObject acForm, sFnew
DoCmd.Rename sFnew, acForm, sN
DoCmd.OpenForm sFnew, acDesign
End Sub
この実行は結構時間がかかります。(初めは、おかしくなったのかと思い止めたりしてました)
タブコントロールの位置決めは難しいですね。(Top が今一つ決まりません)
フォーム「F8M」用のVBAを転記します(同じ標準モジュール内に用意済み)
フォーム「F8M」のVBA記述は「F7M」と大半同じで、以下 Form_Load の黄色部分が異なるだけです。
Do While (Not rs.EOF)
iGyouNew = GyouNum(rs("よみ"))
If (i = 0) Then iGyou = iGyouNew
i = i + 1
If (iGyou <> iGyouNew) Then i = 1
iGyou = iGyouNew
If (iGyou > 10) Then Exit Do
If (i > iM8Count) Then Exit Do
sN = "ck" & iGyou * 100 + i
dic.Item(rs("選手ID").Value) = sN
iGyouNew = GyouNum(rs("よみ"))
If (i = 0) Then iGyou = iGyouNew
i = i + 1
If (iGyou <> iGyouNew) Then i = 1
iGyou = iGyouNew
If (iGyou > 10) Then Exit Do
If (i > iM8Count) Then Exit Do
sN = "ck" & iGyou * 100 + i
dic.Item(rs("選手ID").Value) = sN
2000 のタブコントロール表示は、結構暗いですね。
9)単票に単票サブフォーム(F9M/F9S) (ワークテーブル使用)


VBA は記述したくない・・・ということだったので、テーブル「T出場」を以下の様にすると
チェックボックスを自由に配置できて、操作は楽に(VBA記述なし)なる・・・と言ったものの
これ以降に控えている操作等に支障が出てくると思います。
フィールド | 型 等々 |
---|---|
an | オートナンバ (主キー) |
試合ID | 長整数 「T試合」の試合ID |
ck1 | Yes/No型 ルックアップはチェックボックス |
ck2 | Yes/No型 |
・・・ | |
ck120 | Yes/No型 |
何故か・・・
「ck1」はAさん用、「ck2」はBさん用 等、テーブル内にない取り決めが必要になります。
じゃ、これに近いテーブルをワークテーブル「Tワーク出場9」として使いましょう。
(・・・って VBA 必要になるんじゃ・・・・・横に置いとくとして)
フィールド | 型 等々 |
---|---|
| |
試合ID | 長整数 「T試合」の試合ID |
ck1 | Yes/No型 ルックアップはチェックボックス |
ckn1 | テキスト 選手名 |
ck2 | Yes/No型 |
ckn2 | テキスト 選手名 |
・・・ | |
ck120 | Yes/No型 |
ckn120 | テキスト 選手名 |
【追記 5/15】
上記テーブルのフィールド「an」はありません。
「ck1」は XX さん用という取り決めが必要なので、テーブル「T選手」に情報を持ちましょう・・・・
テーブル「T選手」を「T選手9」にコピーして、フィールドを追加します。
フィールド | 型 等々 |
---|---|
選手ID | オートナンバ (主キー) |
選手名 | テキスト |
よみ | テキスト |
ckno | 数値 使用する ck の番号 |
標準モジュール「S9Make」にテーブル、連結した単票フォームを作成するVBAを用意しました。
Private Const sS9Table As String = "Tワーク出場9"
Private Const sCK As String = "ck"
Private Const sCKN As String = "ckn"
Private Const sFname As String = "F9S"
Private Const IPX As Long = 567
Private Const iRowCount As Long = 20
Public Const iS9Count As Long = 120
' サブフォーム F9S 参照のワークテーブルを作成する
'
Public Sub MakeWorkTable()
Dim tdf As DAO.TableDef
Dim i As Long
On Error Resume Next
With CurrentDb
.TableDefs.Delete sS9Table
Set tdf = .CreateTableDef(sS9Table)
With tdf
.Fields.Append .CreateField("試合ID", dbLong)
For i = 1 To iS9Count
.Fields.Append .CreateField(sCK & i, dbBoolean)
.Fields.Append .CreateField(sCKN & i, dbText, 20)
Next
End With
.TableDefs.Append tdf
Set tdf = Nothing
.TableDefs.Refresh
With .TableDefs(sS9Table)
For i = 1 To iS9Count
With .Fields(sCK & i)
.DefaultValue = "0"
.Properties.Append .CreateProperty("DisplayControl", dbInteger, acCheckBox)
End With
Next
End With
End With
RefreshDatabaseWindow
End Sub
' サブフォーム F9S 作成
'
Public Sub S9MakeProc()
Dim i As Long
Dim sN As String, sNc As String, sNt As String
Dim iRow As Long, iCol As Long
On Error Resume Next
With CreateForm
sN = .Name
.RecordSource = sS9Table
.RecordSelectors = False
.NavigationButtons = False
.AllowAdditions = False
.AllowDeletions = False
.ScrollBars = 0
iRow = IPX * 0.27
iCol = IPX * 0.27
For i = 0 To iS9Count - 1
sNc = sCK & i + 1
sNt = sCKN & i + 1
With CreateControl(sN, acCheckBox, acDetail, , sNc)
.Name = sNc
.Top = (i Mod iRowCount) * IPX * 0.55 + iRow
.Left = (i \ iRowCount) * IPX * 3 + iCol
.Width = IPX * 0.4
.Height = IPX * 0.4
.DefaultValue = "0"
.TabStop = False
.Visible = False
End With
With CreateControl(sN, acTextBox, acDetail, , sNt)
.Name = sNt
.Top = (i Mod iRowCount) * IPX * 0.55 + iRow
.Left = (i \ iRowCount) * IPX * 3 + (IPX * 0.42) + iCol
.Width = IPX * 2
.Height = IPX * 0.45
.Locked = True
.TabStop = False
.Visible = False
.BackStyle = 1
.BackColor = RGB(255, 255, 255)
End With
Next
End With
DoCmd.Close acForm, sN, acSaveYes
DoCmd.DeleteObject acForm, sFname
DoCmd.Rename sFname, acForm, sN
End Sub
Private Const sCK As String = "ck"
Private Const sCKN As String = "ckn"
Private Const sFname As String = "F9S"
Private Const IPX As Long = 567
Private Const iRowCount As Long = 20
Public Const iS9Count As Long = 120
' サブフォーム F9S 参照のワークテーブルを作成する
'
Public Sub MakeWorkTable()
Dim tdf As DAO.TableDef
Dim i As Long
On Error Resume Next
With CurrentDb
.TableDefs.Delete sS9Table
Set tdf = .CreateTableDef(sS9Table)
With tdf
.Fields.Append .CreateField("試合ID", dbLong)
For i = 1 To iS9Count
.Fields.Append .CreateField(sCK & i, dbBoolean)
.Fields.Append .CreateField(sCKN & i, dbText, 20)
Next
End With
.TableDefs.Append tdf
Set tdf = Nothing
.TableDefs.Refresh
With .TableDefs(sS9Table)
For i = 1 To iS9Count
With .Fields(sCK & i)
.DefaultValue = "0"
.Properties.Append .CreateProperty("DisplayControl", dbInteger, acCheckBox)
End With
Next
End With
End With
RefreshDatabaseWindow
End Sub
' サブフォーム F9S 作成
'
Public Sub S9MakeProc()
Dim i As Long
Dim sN As String, sNc As String, sNt As String
Dim iRow As Long, iCol As Long
On Error Resume Next
With CreateForm
sN = .Name
.RecordSource = sS9Table
.RecordSelectors = False
.NavigationButtons = False
.AllowAdditions = False
.AllowDeletions = False
.ScrollBars = 0
iRow = IPX * 0.27
iCol = IPX * 0.27
For i = 0 To iS9Count - 1
sNc = sCK & i + 1
sNt = sCKN & i + 1
With CreateControl(sN, acCheckBox, acDetail, , sNc)
.Name = sNc
.Top = (i Mod iRowCount) * IPX * 0.55 + iRow
.Left = (i \ iRowCount) * IPX * 3 + iCol
.Width = IPX * 0.4
.Height = IPX * 0.4
.DefaultValue = "0"
.TabStop = False
.Visible = False
End With
With CreateControl(sN, acTextBox, acDetail, , sNt)
.Name = sNt
.Top = (i Mod iRowCount) * IPX * 0.55 + iRow
.Left = (i \ iRowCount) * IPX * 3 + (IPX * 0.42) + iCol
.Width = IPX * 2
.Height = IPX * 0.45
.Locked = True
.TabStop = False
.Visible = False
.BackStyle = 1
.BackColor = RGB(255, 255, 255)
End With
Next
End With
DoCmd.Close acForm, sN, acSaveYes
DoCmd.DeleteObject acForm, sFname
DoCmd.Rename sFname, acForm, sN
End Sub
ここで出来上がった「F9S」に以下を記述します。
Private Const EVENT_PROCEDURE As String = "[EVENT PROCEDURE]"
Dim WithEvents frm As Form
Dim dic As Object
Private Function TxtEnter(iNum As Long)
With Me("ck" & iNum)
.SetFocus
If (Me.試合ID <> 0) Then .Value = Not .Value
End With
End Function
Private Sub Form_Open(Cancel As Integer)
Dim sSql As String
Dim rs As DAO.Recordset, rsFrom As DAO.Recordset
Dim i As Long
On Error Resume Next
Set frm = Me.Parent
If (frm Is Nothing) Then
Cancel = True
Exit Sub
End If
frm.OnCurrent = EVENT_PROCEDURE
frm.AfterUpdate = EVENT_PROCEDURE
Set dic = CreateObject("Scripting.Dictionary")
sSql = "DELETE * FROM Tワーク出場9;"
CurrentDb.Execute sSql
Set rs = CurrentDb.OpenRecordset("Tワーク出場9")
rs.AddNew
sSql = "SELECT * FROM T選手9 WHERE ckno > 0 AND ckno <= " & iS9Count & ";"
Set rsFrom = CurrentDb.OpenRecordset(sSql)
While (Not rsFrom.EOF)
i = rsFrom("ckno")
dic.Item(rsFrom("選手ID").Value) = "ck" & i
Me("ck" & i).Visible = True
With Me("ckn" & i)
With .FormatConditions
.Delete
With .Add(acExpression, , "[ck" & i & "]=True")
.BackColor = RGB(255, 240, 240)
End With
End With
.OnEnter = "=TxtEnter(" & i & ")"
.Visible = True
End With
rs("ckn" & i) = rsFrom("選手名")
rsFrom.MoveNext
Wend
rsFrom.Close
Set rsFrom = Nothing
rs.Update
rs.Close
Set rs = Nothing
End Sub
Private Sub frm_Current()
Dim sSql As String
Dim rs As DAO.Recordset, rsFrom As DAO.Recordset
Dim i As Long
Dim id As Long
Set rs = CurrentDb.OpenRecordset("Tワーク出場9")
rs.Edit
For i = 1 To iS9Count
rs("ck" & i) = False
Next
id = Nz(frm.試合ID)
rs("試合ID") = id
If (id <> 0) Then
sSql = "SELECT ckno FROM T出場 INNER JOIN T選手9 " _
& "ON T出場.選手ID = T選手9.選手ID " _
& "WHERE T出場.試合ID = " & id & ";"
Set rsFrom = CurrentDb.OpenRecordset(sSql)
While (Not rsFrom.EOF)
i = rsFrom(0)
If (i > 0 And i <= iS9Count) Then rs("ck" & i) = True
rsFrom.MoveNext
Wend
rsFrom.Close
Set rsFrom = Nothing
End If
rs.Update
rs.Close
Set rs = Nothing
Me.Requery
End Sub
Private Sub frm_AfterUpdate()
Call frm_Current
End Sub
Private Sub Form_Dirty(Cancel As Integer)
If (Me.試合ID = 0) Then Cancel = True
End Sub
Private Sub Form_AfterUpdate()
Dim sSql As String
Dim v As Variant
Dim i As Long
sSql = "DELETE * FROM T出場 WHERE 試合ID = " & Me.試合ID & ";"
CurrentDb.Execute sSql
For Each v In dic.Keys
With Me(dic.Item(v))
If (.Value) Then
sSql = "INSERT INTO T出場(試合ID, 選手ID) VALUES (" _
& Me.試合ID & "," & v & ");"
CurrentDb.Execute sSql
End If
End With
Next
End Sub
Private Sub Form_Close()
Set frm = Nothing
End Sub
Dim WithEvents frm As Form
Dim dic As Object
Private Function TxtEnter(iNum As Long)
With Me("ck" & iNum)
.SetFocus
If (Me.試合ID <> 0) Then .Value = Not .Value
End With
End Function
Private Sub Form_Open(Cancel As Integer)
Dim sSql As String
Dim rs As DAO.Recordset, rsFrom As DAO.Recordset
Dim i As Long
On Error Resume Next
Set frm = Me.Parent
If (frm Is Nothing) Then
Cancel = True
Exit Sub
End If
frm.OnCurrent = EVENT_PROCEDURE
frm.AfterUpdate = EVENT_PROCEDURE
Set dic = CreateObject("Scripting.Dictionary")
sSql = "DELETE * FROM Tワーク出場9;"
CurrentDb.Execute sSql
Set rs = CurrentDb.OpenRecordset("Tワーク出場9")
rs.AddNew
sSql = "SELECT * FROM T選手9 WHERE ckno > 0 AND ckno <= " & iS9Count & ";"
Set rsFrom = CurrentDb.OpenRecordset(sSql)
While (Not rsFrom.EOF)
i = rsFrom("ckno")
dic.Item(rsFrom("選手ID").Value) = "ck" & i
Me("ck" & i).Visible = True
With Me("ckn" & i)
With .FormatConditions
.Delete
With .Add(acExpression, , "[ck" & i & "]=True")
.BackColor = RGB(255, 240, 240)
End With
End With
.OnEnter = "=TxtEnter(" & i & ")"
.Visible = True
End With
rs("ckn" & i) = rsFrom("選手名")
rsFrom.MoveNext
Wend
rsFrom.Close
Set rsFrom = Nothing
rs.Update
rs.Close
Set rs = Nothing
End Sub
Private Sub frm_Current()
Dim sSql As String
Dim rs As DAO.Recordset, rsFrom As DAO.Recordset
Dim i As Long
Dim id As Long
Set rs = CurrentDb.OpenRecordset("Tワーク出場9")
rs.Edit
For i = 1 To iS9Count
rs("ck" & i) = False
Next
id = Nz(frm.試合ID)
rs("試合ID") = id
If (id <> 0) Then
sSql = "SELECT ckno FROM T出場 INNER JOIN T選手9 " _
& "ON T出場.選手ID = T選手9.選手ID " _
& "WHERE T出場.試合ID = " & id & ";"
Set rsFrom = CurrentDb.OpenRecordset(sSql)
While (Not rsFrom.EOF)
i = rsFrom(0)
If (i > 0 And i <= iS9Count) Then rs("ck" & i) = True
rsFrom.MoveNext
Wend
rsFrom.Close
Set rsFrom = Nothing
End If
rs.Update
rs.Close
Set rs = Nothing
Me.Requery
End Sub
Private Sub frm_AfterUpdate()
Call frm_Current
End Sub
Private Sub Form_Dirty(Cancel As Integer)
If (Me.試合ID = 0) Then Cancel = True
End Sub
Private Sub Form_AfterUpdate()
Dim sSql As String
Dim v As Variant
Dim i As Long
sSql = "DELETE * FROM T出場 WHERE 試合ID = " & Me.試合ID & ";"
CurrentDb.Execute sSql
For Each v In dic.Keys
With Me(dic.Item(v))
If (.Value) Then
sSql = "INSERT INTO T出場(試合ID, 選手ID) VALUES (" _
& Me.試合ID & "," & v & ");"
CurrentDb.Execute sSql
End If
End With
Next
End Sub
Private Sub Form_Close()
Set frm = Nothing
End Sub
メインとなるフォーム「F9M」はフォーム「F6M_BASE」をコピーしたもの。
そこに、この「F9S」をドラッグ&ドロップしてサブフォームとして組み込み、
リンク親/子フィールドは削除(空欄に)します。
どの選手が、どの「ck」を使うか、テーブル「T選手9」の「ckno」を変更しない限り、
その選手はその番号を使う事になるので、連結されたチェックボックス/テキストボックスを
(ペアにして)自由に移動配置できます。
なお、このワークテーブル「Tワーク出場9」のレコードは1件だけ。
それを UPDATE で使い回しします。
(処理対象でない試合のものに対して、レコードをいじりたくないので)
連結にしてみたものの、何か遠まわりしているような・・・・していないような・・・
でも、ガ~~ってチェックして、それを取り消すのは楽かな。
メイン/サブの構成になったので、「登録/修正」用のボタンはなし。
今までのフォームと表示が異なっていますが、気がつかれたでしょうか。
今までのフォームの表示順は、「よみ」順になっていましたが、
このフォームでは選手の登録順(ckno の順)になっています。
(配置を移動していなかったので、そう見えたという事だけですけど)
そうそう
このフォームだったと思うけど、Form_Open / Form_Load が連続して呼ばれない・・・
当初 Form_Open / Form_Load は以下のような感じ
Private Sub Form_Open(Cancel As Integer)
On Error Resume Next
If (Me.Parent.Name = "") Then
Cancel = True
End If
End Sub
Private Sub Form_Load()
Dim sSql As String
Dim rs As DAO.Recordset, rsFrom As DAO.Recordset
Dim i As Long
Set frm = Me.Parent
frm.OnCurrent = EVENT_PROCEDURE
frm.AfterUpdate = EVENT_PROCEDURE
Set dic = CreateObject("Scripting.Dictionary")
・・・・
Form_Open でやっているのは、過去記事にもいろいろと書いてましたが、On Error Resume Next
If (Me.Parent.Name = "") Then
Cancel = True
End If
End Sub
Private Sub Form_Load()
Dim sSql As String
Dim rs As DAO.Recordset, rsFrom As DAO.Recordset
Dim i As Long
Set frm = Me.Parent
frm.OnCurrent = EVENT_PROCEDURE
frm.AfterUpdate = EVENT_PROCEDURE
Set dic = CreateObject("Scripting.Dictionary")
・・・・
サブフォームとして起動されていなかったら表示しない・・・・
でも、この後の
Private Sub frm_Current()
Dim sSql As String
Dim rs As DAO.Recordset, rsFrom As DAO.Recordset
Dim i As Long
Dim id As Long
Set rs = CurrentDb.OpenRecordset("Tワーク出場9")
rs.Edit ' ★★★1
For i = 1 To iS9Count
rs("ck" & i) = False
Next
id = Nz(frm.試合ID) ' ★★★2
rs("試合ID") = id
・・・・
のDim sSql As String
Dim rs As DAO.Recordset, rsFrom As DAO.Recordset
Dim i As Long
Dim id As Long
Set rs = CurrentDb.OpenRecordset("Tワーク出場9")
rs.Edit ' ★★★1
For i = 1 To iS9Count
rs("ck" & i) = False
Next
id = Nz(frm.試合ID) ' ★★★2
rs("試合ID") = id
・・・・
★★★1 部分だったかで「カレントレコードがない」エラー(だったか)
★★★2 部分だったかで frm がどうたらだったか・・・
で、2000 の方でチョッといじっていると、動いてみたり・・・
同じVBA記述構成の他のフォームは動いていたり・・・・
なので、サブフォームになる Form_Open / Form_Load は Open 1つに(全部書き直し)
【追記 5/15】
ここで示した箇所の例は嘘ですね。
Set frm = Me.Parent
frm.OnCurrent = EVENT_PROCEDURE
されていないと、frm_Current は動きませんよね・・・・frm.OnCurrent = EVENT_PROCEDURE
でも、どこかのフォームでなっていたんですよ・・・・
ま、私の中での出来事と言う事で・・・・・
注意事項)
・メイン/サブの構成では、サブ側でメインのイベントを受け取る設定をするので
メイン側フォームのプロパティ「コード保持」は「はい」としておきます。
(メイン側に VBA 記述がなくても)
(F2M/F2S1/F2S2 では、「T試合」を表示している F2S1 が対象)
・フォーム「F6M」以降のフォームで、選手を割付ける際、割り付けきらなかったとか・・・・
以降の処理でエラーになる可能性・・・大・大・大
どの方法が良いのだろう・・・・
サンプルは以下 | ||||||||||||
| ||||||||||||
※ ファイルは zip 形式 | ||||||||||||
※ 2007 以外は、2007 保存時に変換 & 各バージョンで動作確認 & 最適化 |
- 関連記事
-
- ファイル名をください (2011/07/03)
- 検索用途コンボの4階層連携 その2 (2014/07/12)
- ××専用(限定)・・・ (2013/08/10)
- 更新できないクエリでどうにか (2011/11/26)
- 起動元に値を設定 (2011/06/14)
- 深夜時間の計算 (2013/09/15)
- 大量なデータはどうする (2011/11/26)
- 出力項目指定の模索 (2013/04/06)
- 帳票サブフォーム間の同期 (2012/08/01)
- Excelへの出力 まとめ(シーズン1) (2013/12/14)
- 表示=入力なの? (2011/10/10)
- Excel VBA をやってみた その16 (2015/05/26)
- 採番する (2011/11/26)
2012/05/14
Category: サンプルかな
« 重ねる
Excel VBA をやってみた その3(合計値検索) »
この記事に対するコメント
トラックバック
| h o m e |