表示=入力なの?
表示したら、その画面(フォーム)のまま入力したい。・・・ってどうなのでしょう?
特に表示したものは、複数のテーブルから構成されており・・・・
安易(容易)に入力できるものだろうか・・・???
私は結構割り切ってます。
表示は表示・・・・入力は入力・・・
入力する時には、1フォーム・・・基本1テーブルと考えてます。
テーブルがリレーションイシップメージで段々になっているのなら、
個々をサブフォームとして表現するようにしています。
なぜなら、表示は更新する必要が無いので、クエリを作るにしても更新できる/できない・・・
を考える必要が無い。。。。
入力が絡むと、1フォーム1テーブルで考えた方が間違いない・・・とも。
ここで、以下のようなテーブルがあり、リレーションシップが設定されているとします。

この時、一連の設定状況を見ながら入力/更新していくには・・・・
(上の段と、下の段は同じものです。後述する処理で単に別物としただけです)
ここでは、表示にリストボックスを用いて、
入力用には個々のテーブルに対応したサブフォームを使ってみることにします。
また、サブフォームに表示する元々のフォームを1つにしてみました。
サブフォームとして組み込む時、1つのフォームを複数のサブフォームに指定することが出来ます。
が、注意事項として、
例えば、コマンドボタンの Visible を変更すると、他のサブフォーム表示にも影響する・・・
これを考えないといけません。
(帳票フォームの詳細にコマンドボタンを配置した時に、個別に制御できない、それと同じです)
上記テーブル構成を考えた時、以下のようなフォームを考えてみました。


で、サブフォーム部分は右側4段ですが、そこに使っているのは

で、どのテーブルに対して・・・・固定情報は持たないようにしました。
サブフォーム「FS1」の作成
フォームデザインで作成していきます。
単票としてシンプルに作っていきます。
各テーブルに共通して入力しないといけない部分を可視で作成していきます。
「txt1」として、日付部分、「txt2」として、内容の入力部分(T受付では担当者として)
非表示部分として、各テーブルに必要なものを作っておきます。
フィールド「use」用に、オプションボタン「op11」
自分のID用に「txt11」
親のID用に「txt12」
サブフォームになっているっていう事は、
単にフォームを起動する時のように WhereCondition を指定できるでもないし、OpenArg を渡せるでもない。
そこで、サブフォームとして設定する前に、親の Tag に必要な情報を設定しておき、
その後で、サブフォームコントロールのソースオブジェストにサブフォームを設定することで、
Open イベント時に、親の Tag を参照させ必要な情報を入手するようにしました。
この時、例えば、親の Tag に
"2,T見積,見積日付,見積内容,見積ID,受付ID" とあれば、
私は2番
対象のテーブルは「T見積」
「txt1」は、「見積日付」に連結
「txt2」は、「見積内容」に連結
で、自分のIDは「見積ID」で、「txt11」に連結
また、親のIDは、「受付ID」で、「txt12」に連結
ってな具合で、情報を Tag 経由で通知します。
その後、子と親でやり取りしますが、私は「 X 番」を使って行います。
オプションボタンは、そのレコードが有効/無効の意味を持つ「use」と連結しておきます。
(ただし、「F1」「FS1」のパターン時には使用していません)
フォーム「FS1」は単票フォームとして作成しておきます。
「レコードセレクタ」「移動ボタン」は「いいえ」
基本的には、この「FS1」のOpen 時に、自分は何を表示するのか・・・・
親とやり取りしながら Filter を設定します。
設定する Filter が無ければ、データ入力用に設定します。
単票で、移動ボタンが無いので、現レコードと新規の切り替えは「Page Up」「Page Down」で切り分けます。
で、どの状況にあるか表示しておきます。
テキストボックス「ts1」のコントロールソースに =IIf([DataEntry] Or [NewRecord],"新規","更新")
さらに、条件付き書式で フィールドの値が "新規" なら「赤で斜体」に・・・
また、いじれない様に「編集ロック」を「はい」、「使用可能」を「いいえ」に
記述したVBAは
Dim myNo As Integer
Dim bNewEdit As Boolean
Private Sub Form_Open(Cancel As Integer)
Dim sAry() As String
On Error Resume Next
sAry = Split(Me.Parent.Tag, ",")
If (Err <> 0) Then
Cancel = True
Exit Sub
End If
myNo = CInt(sAry(0))
Me.RecordSource = sAry(1)
Me.txt1.ControlSource = sAry(2)
Me.txt1.Controls(0).Caption = sAry(2)
Me.txt2.ControlSource = sAry(3)
Me.txt2.Controls(0).Caption = sAry(3)
Me.op11.ControlSource = "use"
Me.txt11.ControlSource = sAry(4)
Me.txt12.ControlSource = sAry(5)
Me.Filter = Me.Parent.GetMyFilter(myNo)
Me.FilterOn = Len(Me.Filter) > 0
If (Not Me.FilterOn) Then
Me.DataEntry = True
End If
bNewEdit = False
End Sub
Private Sub Form_Current()
If (bNewEdit) Then Call Me.Parent.ReShow(myNo)
bNewEdit = False
End Sub
Private Sub Form_BeforeInsert(Cancel As Integer)
Call Me.Parent.NewMyItemReset(myNo)
bNewEdit = True
End Sub
Private Sub Form_BeforeUpdate(Cancel As Integer)
If (Me.NewRecord) Then
Me.txt11 = Nz(DMax(Me.txt11.ControlSource, Me.RecordSource), 0) + 1
If (Len(Me.txt12.ControlSource) > 0) Then
Me.txt12 = Me.Parent.GetMyParentItem(myNo)
End If
End If
End Sub
Private Sub Form_AfterUpdate()
Call Me.Parent.NewMyItemSet(myNo, Me.txt11)
bNewEdit = False
End Sub
Dim bNewEdit As Boolean
Private Sub Form_Open(Cancel As Integer)
Dim sAry() As String
On Error Resume Next
sAry = Split(Me.Parent.Tag, ",")
If (Err <> 0) Then
Cancel = True
Exit Sub
End If
myNo = CInt(sAry(0))
Me.RecordSource = sAry(1)
Me.txt1.ControlSource = sAry(2)
Me.txt1.Controls(0).Caption = sAry(2)
Me.txt2.ControlSource = sAry(3)
Me.txt2.Controls(0).Caption = sAry(3)
Me.op11.ControlSource = "use"
Me.txt11.ControlSource = sAry(4)
Me.txt12.ControlSource = sAry(5)
Me.Filter = Me.Parent.GetMyFilter(myNo)
Me.FilterOn = Len(Me.Filter) > 0
If (Not Me.FilterOn) Then
Me.DataEntry = True
End If
bNewEdit = False
End Sub
Private Sub Form_Current()
If (bNewEdit) Then Call Me.Parent.ReShow(myNo)
bNewEdit = False
End Sub
Private Sub Form_BeforeInsert(Cancel As Integer)
Call Me.Parent.NewMyItemReset(myNo)
bNewEdit = True
End Sub
Private Sub Form_BeforeUpdate(Cancel As Integer)
If (Me.NewRecord) Then
Me.txt11 = Nz(DMax(Me.txt11.ControlSource, Me.RecordSource), 0) + 1
If (Len(Me.txt12.ControlSource) > 0) Then
Me.txt12 = Me.Parent.GetMyParentItem(myNo)
End If
End If
End Sub
Private Sub Form_AfterUpdate()
Call Me.Parent.NewMyItemSet(myNo, Me.txt11)
bNewEdit = False
End Sub
親フォーム「F1」の作成
親はフォームデザインで作成していきます。
単票として、「レコードセレクタ」「移動ボタン」は「いいえ」にしておきます。
4つのテーブルを簡易に表示するものとしてリストボックス「lst1」を作っておきます。
値集合ソースは、入力しないので表示できれば良いもので作ります。
SELECT
IdMake(T1.受付ID,T2.見積ID,T3.契約ID,T4.完了ID) AS ID,
T1.受付ID,
T1.受付日付,
T2.見積ID,
T2.見積日付,
T3.契約ID,
T3.契約日付,
T4.完了ID,
T4.完了日付,
Switch(IsNull(T1.受付日付),0,IsNull(T2.見積日付),1,IsNull(T3.契約日付),2,IsNull(T4.完了日付),3,True,4) AS 判定
FROM
(((SELECT * FROM T受付 WHERE use=True) AS T1
LEFT JOIN
(SELECT * FROM T見積 WHERE use=True) AS T2 ON T1.受付ID=T2.受付ID)
LEFT JOIN (SELECT * FROM T契約 WHERE use=True) AS T3 ON T2.見積ID=T3.見積ID)
LEFT JOIN (SELECT * FROM T完了 WHERE use=True) AS T4 ON T3.契約ID=T4.契約ID
ORDER BY IdMake(T1.受付ID,T2.見積ID,T3.契約ID,T4.完了ID) DESC;
列数は 10IdMake(T1.受付ID,T2.見積ID,T3.契約ID,T4.完了ID) AS ID,
T1.受付ID,
T1.受付日付,
T2.見積ID,
T2.見積日付,
T3.契約ID,
T3.契約日付,
T4.完了ID,
T4.完了日付,
Switch(IsNull(T1.受付日付),0,IsNull(T2.見積日付),1,IsNull(T3.契約日付),2,IsNull(T4.完了日付),3,True,4) AS 判定
FROM
(((SELECT * FROM T受付 WHERE use=True) AS T1
LEFT JOIN
(SELECT * FROM T見積 WHERE use=True) AS T2 ON T1.受付ID=T2.受付ID)
LEFT JOIN (SELECT * FROM T契約 WHERE use=True) AS T3 ON T2.見積ID=T3.見積ID)
LEFT JOIN (SELECT * FROM T完了 WHERE use=True) AS T4 ON T3.契約ID=T4.契約ID
ORDER BY IdMake(T1.受付ID,T2.見積ID,T3.契約ID,T4.完了ID) DESC;
列幅は 0cm;0cm;2.503cm;0cm;2.503cm;0cm;2.503cm;0cm;2.503cm;1cm
(日付部分のみが表示されるように)
IdMake はユーザ定義関数として、標準モジュールに記述したもので、
一覧にした時に、そのレコードを1意に特定するための文字列を作るもので
Public Function IdMake(ParamArray vAry()) As String
Dim i As Integer
Dim sS As String
Dim sTmp As String
sS = ""
For i = LBound(vAry) To UBound(vAry)
sTmp = Nz(vAry(i))
If (Len(sTmp) = 0) Then sTmp = "Z"
sS = sS & "-" & sTmp
Next
IdMake = Mid(sS, 2)
End Function
各テーブルの「xxxID」を連結して作成しています。Dim i As Integer
Dim sS As String
Dim sTmp As String
sS = ""
For i = LBound(vAry) To UBound(vAry)
sTmp = Nz(vAry(i))
If (Len(sTmp) = 0) Then sTmp = "Z"
sS = sS & "-" & sTmp
Next
IdMake = Mid(sS, 2)
End Function
リストボックスの上には、各テーブルでの「ID」を格納しておくテキストボックスを配置。
リストボックスがクリックされた時点で、テキストボックスに値を設定します。
が、テーブル上 Null の値は、リストボックス上では "" になるため、
テキストボックスの何もない状態は "" になります。
(この辺、注意!!)
で、各状態をサブフォームとやり取りする関数を Public 宣言しておきます。
やり取りの主は、サブフォームごとに割り付けた「番号」を使って行います。
VBAで記述したものは以下
Dim CSUB(1 To 4) As Variant
Private Sub initCnst()
CSUB(1) = Array("txt1", "受付ID", "1,T受付,受付日付,担当者,受付ID,")
CSUB(2) = Array("txt2", "見積ID", "2,T見積,見積日付,見積内容,見積ID,受付ID")
CSUB(3) = Array("txt3", "契約ID", "3,T契約,契約日付,契約内容,契約ID,見積ID")
CSUB(4) = Array("txt4", "完了ID", "4,T完了,完了日付,完了内容,完了ID,契約ID")
End Sub
Public Function GetMyFilter(iNum As Integer) As String
Dim s As String
GetMyFilter = ""
s = Me(CSUB(iNum)(0))
If (Len(s) > 0) Then
GetMyFilter = CSUB(iNum)(1) & " = " & s
End If
End Function
Public Function GetMyParentItem(iNum As Integer) As Long
Dim i As Integer
Dim s As String
GetMyParentItem = 0
i = iNum - 1
If (i > 0) Then
s = Me(CSUB(i)(0))
If (Len(s) = 0) Then
GetMyParentItem = 0
Else
GetMyParentItem = CLng(s)
End If
End If
End Function
Public Sub NewMyItemReset(iNum As Integer)
Dim i As Integer
If (Len(Me(CSUB(iNum)(0))) = 0) Then Exit Sub
DoCmd.Echo False
For i = iNum To 4
Me("txt" & i) = ""
Next
For i = iNum + 1 To 4
With Me("FSUB" & i)
.Visible = False
.SourceObject = ""
End With
Next
DoCmd.Echo True
End Sub
Public Sub NewMyItemSet(iNum As Integer, iSrc As Long)
Dim sTxt As String
DoCmd.Echo False
sTxt = CSUB(iNum)(0)
If (Me(sTxt) <> iSrc) Then
Me(sTxt) = iSrc
Me.lst1 = IdMake(Me.txt1.Value, Me.txt2.Value, Me.txt3.Value, Me.txt4.Value)
End If
Me.lst1.Requery
Call ShowFSub(iNum)
With Me("FSUB" & Choose(iNum, 2, 3, 4, 1))
.SetFocus
.Form.txt1.SetFocus
End With
DoCmd.Echo True
End Sub
Public Sub ReShow(iNum As Integer)
DoCmd.Echo False
Call lst1_Click
With Me("FSUB" & iNum)
.SetFocus
.Form.txt1.SetFocus
End With
DoCmd.Echo True
End Sub
Private Sub ShowFSub(iNum As Integer)
Dim i As Integer
Dim bShow As Boolean
bShow = True
For i = iNum To 4
With Me("FSUB" & i)
If (bShow) Then
Me.Tag = CSUB(i)(2)
.SourceObject = "FS1"
.Visible = True
If (Len(Me(CSUB(i)(0))) = 0) Then bShow = False
Else
.Visible = False
.SourceObject = ""
End If
End With
Next
Me.Tag = ""
End Sub
Private Sub init()
Dim i As Integer
Me.lst1 = Null
Me.lst1.Requery
For i = 1 To 4
Me("txt" & i) = ""
With Me("FSUB" & i)
.Visible = False
.SourceObject = ""
End With
Next
End Sub
Private Sub Form_Load()
Call initCnst
Call init
End Sub
Private Sub lst1_Click()
DoCmd.Echo False
Me.txt1 = Me.lst1.Column(1)
Me.txt2 = Me.lst1.Column(3)
Me.txt3 = Me.lst1.Column(5)
Me.txt4 = Me.lst1.Column(7)
Call ShowFSub(1)
DoCmd.Echo True
End Sub
Private Sub btn1_Click()
DoCmd.Echo False
Call init
DoCmd.Echo True
End Sub
Private Sub btn2_Click()
DoCmd.Echo False
Call init
Me.Tag = CSUB(1)(2)
With Me("FSUB1")
.SourceObject = "FS1"
.Visible = True
.SetFocus
.Form.txt1.SetFocus
End With
Me.Tag = ""
DoCmd.Echo True
End Sub
Private Sub initCnst()
CSUB(1) = Array("txt1", "受付ID", "1,T受付,受付日付,担当者,受付ID,")
CSUB(2) = Array("txt2", "見積ID", "2,T見積,見積日付,見積内容,見積ID,受付ID")
CSUB(3) = Array("txt3", "契約ID", "3,T契約,契約日付,契約内容,契約ID,見積ID")
CSUB(4) = Array("txt4", "完了ID", "4,T完了,完了日付,完了内容,完了ID,契約ID")
End Sub
Public Function GetMyFilter(iNum As Integer) As String
Dim s As String
GetMyFilter = ""
s = Me(CSUB(iNum)(0))
If (Len(s) > 0) Then
GetMyFilter = CSUB(iNum)(1) & " = " & s
End If
End Function
Public Function GetMyParentItem(iNum As Integer) As Long
Dim i As Integer
Dim s As String
GetMyParentItem = 0
i = iNum - 1
If (i > 0) Then
s = Me(CSUB(i)(0))
If (Len(s) = 0) Then
GetMyParentItem = 0
Else
GetMyParentItem = CLng(s)
End If
End If
End Function
Public Sub NewMyItemReset(iNum As Integer)
Dim i As Integer
If (Len(Me(CSUB(iNum)(0))) = 0) Then Exit Sub
DoCmd.Echo False
For i = iNum To 4
Me("txt" & i) = ""
Next
For i = iNum + 1 To 4
With Me("FSUB" & i)
.Visible = False
.SourceObject = ""
End With
Next
DoCmd.Echo True
End Sub
Public Sub NewMyItemSet(iNum As Integer, iSrc As Long)
Dim sTxt As String
DoCmd.Echo False
sTxt = CSUB(iNum)(0)
If (Me(sTxt) <> iSrc) Then
Me(sTxt) = iSrc
Me.lst1 = IdMake(Me.txt1.Value, Me.txt2.Value, Me.txt3.Value, Me.txt4.Value)
End If
Me.lst1.Requery
Call ShowFSub(iNum)
With Me("FSUB" & Choose(iNum, 2, 3, 4, 1))
.SetFocus
.Form.txt1.SetFocus
End With
DoCmd.Echo True
End Sub
Public Sub ReShow(iNum As Integer)
DoCmd.Echo False
Call lst1_Click
With Me("FSUB" & iNum)
.SetFocus
.Form.txt1.SetFocus
End With
DoCmd.Echo True
End Sub
Private Sub ShowFSub(iNum As Integer)
Dim i As Integer
Dim bShow As Boolean
bShow = True
For i = iNum To 4
With Me("FSUB" & i)
If (bShow) Then
Me.Tag = CSUB(i)(2)
.SourceObject = "FS1"
.Visible = True
If (Len(Me(CSUB(i)(0))) = 0) Then bShow = False
Else
.Visible = False
.SourceObject = ""
End If
End With
Next
Me.Tag = ""
End Sub
Private Sub init()
Dim i As Integer
Me.lst1 = Null
Me.lst1.Requery
For i = 1 To 4
Me("txt" & i) = ""
With Me("FSUB" & i)
.Visible = False
.SourceObject = ""
End With
Next
End Sub
Private Sub Form_Load()
Call initCnst
Call init
End Sub
Private Sub lst1_Click()
DoCmd.Echo False
Me.txt1 = Me.lst1.Column(1)
Me.txt2 = Me.lst1.Column(3)
Me.txt3 = Me.lst1.Column(5)
Me.txt4 = Me.lst1.Column(7)
Call ShowFSub(1)
DoCmd.Echo True
End Sub
Private Sub btn1_Click()
DoCmd.Echo False
Call init
DoCmd.Echo True
End Sub
Private Sub btn2_Click()
DoCmd.Echo False
Call init
Me.Tag = CSUB(1)(2)
With Me("FSUB1")
.SourceObject = "FS1"
.Visible = True
.SetFocus
.Form.txt1.SetFocus
End With
Me.Tag = ""
DoCmd.Echo True
End Sub
これで、大体の動きはわかるかな・・・・と思います。
ただ、各テーブルに設けていた「use」(このレコードは有効/無効)を使っていないので、
途中でレコードを新規作成しても、前のデータはそのまま残っていったと思います。
ということで、途中新規作成したら、今までのものは無効とするうごきのもの・・・
フォーム「F2」と「FS2」の組み合わせ・・・・
を次に・・・
途中で新規を作成したら、その時点(そのテーブル)の「use」を変更します。
変更することで、それ以降下のものは現れないようになります。
(リストボックスの表示で「use」を見て抽出するようにしていたから・・・)
データ(レコード)自体は削除していないので、メンテナンス時点にでも削除してみるとか・・・
「F1」「F2」での動きの違いを感じられたらと・・・・
なお、「F1」は上の段のテーブル群を、「F2」は下の段のテーブル群を使っています。
(各テーブルの構成は同じです)
「FS2」のVBA
Dim myNo As Integer
Dim bNewEdit As Boolean
Private Sub Form_Open(Cancel As Integer)
Dim sAry() As String
On Error Resume Next
sAry = Split(Me.Parent.Tag, ",")
If (Err <> 0) Then
Cancel = True
Exit Sub
End If
myNo = CInt(sAry(0))
Me.RecordSource = sAry(1)
Me.txt1.ControlSource = sAry(2)
Me.txt1.Controls(0).Caption = sAry(2)
Me.txt2.ControlSource = sAry(3)
Me.txt2.Controls(0).Caption = sAry(3)
Me.op11.ControlSource = "use"
Me.txt11.ControlSource = sAry(4)
Me.txt12.ControlSource = sAry(5)
Me.Filter = Me.Parent.GetMyFilter(myNo)
Me.FilterOn = Len(Me.Filter) > 0
If (Not Me.FilterOn) Then
Me.DataEntry = True
End If
bNewEdit = False
End Sub
Private Sub Form_Current()
If (bNewEdit) Then Call Me.Parent.ReShow(myNo)
bNewEdit = False
End Sub
Private Sub Form_BeforeInsert(Cancel As Integer)
Call Me.Parent.NewMyItemReset(myNo)
bNewEdit = True
End Sub
Private Sub Form_BeforeUpdate(Cancel As Integer)
If (Me.NewRecord) Then
Me.txt11 = Nz(DMax(Me.txt11.ControlSource, Me.RecordSource), 0) + 1
If (Len(Me.txt12.ControlSource) > 0) Then
Me.txt12 = Me.Parent.GetMyParentItem(myNo)
End If
End If
End Sub
Private Sub Form_AfterUpdate()
Dim sSql As String
If ((bNewEdit) And (Me.FilterOn) And (Len(Me.txt12.ControlSource) > 0)) Then
sSql = "UPDATE " & Me.RecordSource & " SET use = False " _
& "WHERE " & Me.Filter & " ;"
CurrentDb.Execute sSql
End If
Call Me.Parent.NewMyItemSet(myNo, Me.txt11)
bNewEdit = False
End Sub
Dim bNewEdit As Boolean
Private Sub Form_Open(Cancel As Integer)
Dim sAry() As String
On Error Resume Next
sAry = Split(Me.Parent.Tag, ",")
If (Err <> 0) Then
Cancel = True
Exit Sub
End If
myNo = CInt(sAry(0))
Me.RecordSource = sAry(1)
Me.txt1.ControlSource = sAry(2)
Me.txt1.Controls(0).Caption = sAry(2)
Me.txt2.ControlSource = sAry(3)
Me.txt2.Controls(0).Caption = sAry(3)
Me.op11.ControlSource = "use"
Me.txt11.ControlSource = sAry(4)
Me.txt12.ControlSource = sAry(5)
Me.Filter = Me.Parent.GetMyFilter(myNo)
Me.FilterOn = Len(Me.Filter) > 0
If (Not Me.FilterOn) Then
Me.DataEntry = True
End If
bNewEdit = False
End Sub
Private Sub Form_Current()
If (bNewEdit) Then Call Me.Parent.ReShow(myNo)
bNewEdit = False
End Sub
Private Sub Form_BeforeInsert(Cancel As Integer)
Call Me.Parent.NewMyItemReset(myNo)
bNewEdit = True
End Sub
Private Sub Form_BeforeUpdate(Cancel As Integer)
If (Me.NewRecord) Then
Me.txt11 = Nz(DMax(Me.txt11.ControlSource, Me.RecordSource), 0) + 1
If (Len(Me.txt12.ControlSource) > 0) Then
Me.txt12 = Me.Parent.GetMyParentItem(myNo)
End If
End If
End Sub
Private Sub Form_AfterUpdate()
Dim sSql As String
If ((bNewEdit) And (Me.FilterOn) And (Len(Me.txt12.ControlSource) > 0)) Then
sSql = "UPDATE " & Me.RecordSource & " SET use = False " _
& "WHERE " & Me.Filter & " ;"
CurrentDb.Execute sSql
End If
Call Me.Parent.NewMyItemSet(myNo, Me.txt11)
bNewEdit = False
End Sub
「F2」のVBA
Dim CSUB(1 To 4) As Variant
Private Sub initCnst()
CSUB(1) = Array("txt1", "受付ID", "1,T受付2,受付日付,担当者,受付ID,")
CSUB(2) = Array("txt2", "見積ID", "2,T見積2,見積日付,見積内容,見積ID,受付ID")
CSUB(3) = Array("txt3", "契約ID", "3,T契約2,契約日付,契約内容,契約ID,見積ID")
CSUB(4) = Array("txt4", "完了ID", "4,T完了2,完了日付,完了内容,完了ID,契約ID")
End Sub
Public Function GetMyFilter(iNum As Integer) As String
Dim s As String
GetMyFilter = ""
s = Me(CSUB(iNum)(0))
If (Len(s) > 0) Then
GetMyFilter = CSUB(iNum)(1) & " = " & s
End If
End Function
Public Function GetMyParentItem(iNum As Integer) As Long
Dim i As Integer
Dim s As String
GetMyParentItem = 0
i = iNum - 1
If (i > 0) Then
s = Me(CSUB(i)(0))
If (Len(s) = 0) Then
GetMyParentItem = 0
Else
GetMyParentItem = CLng(s)
End If
End If
End Function
Public Sub NewMyItemReset(iNum As Integer)
Dim i As Integer
If (Len(Me(CSUB(iNum)(0))) = 0) Then Exit Sub
DoCmd.Echo False
For i = iNum To 4
Me("txt" & i) = ""
Next
For i = iNum + 1 To 4
With Me("FSUB" & i)
.Visible = False
.SourceObject = ""
End With
Next
DoCmd.Echo True
End Sub
Public Sub NewMyItemSet(iNum As Integer, iSrc As Long)
Dim sTxt As String
DoCmd.Echo False
sTxt = CSUB(iNum)(0)
If (Me(sTxt) <> iSrc) Then
Me(sTxt) = iSrc
Me.lst1 = IdMake(Me.txt1.Value, Me.txt2.Value, Me.txt3.Value, Me.txt4.Value)
End If
Me.lst1.Requery
Call ShowFSub(iNum)
With Me("FSUB" & Choose(iNum, 2, 3, 4, 1))
.SetFocus
.Form.txt1.SetFocus
End With
DoCmd.Echo True
End Sub
Public Sub ReShow(iNum As Integer)
DoCmd.Echo False
Call lst1_Click
With Me("FSUB" & iNum)
.SetFocus
.Form.txt1.SetFocus
End With
DoCmd.Echo True
End Sub
Private Sub ShowFSub(iNum As Integer)
Dim i As Integer
Dim bShow As Boolean
bShow = True
For i = iNum To 4
With Me("FSUB" & i)
If (bShow) Then
Me.Tag = CSUB(i)(2)
.SourceObject = "FS2"
.Visible = True
If (Len(Me(CSUB(i)(0))) = 0) Then bShow = False
Else
.Visible = False
.SourceObject = ""
End If
End With
Next
Me.Tag = ""
End Sub
Private Sub init()
Dim i As Integer
Me.lst1 = Null
Me.lst1.Requery
For i = 1 To 4
Me("txt" & i) = ""
With Me("FSUB" & i)
.Visible = False
.SourceObject = ""
End With
Next
End Sub
Private Sub Form_Load()
Call initCnst
Call init
End Sub
Private Sub lst1_Click()
DoCmd.Echo False
Me.txt1 = Me.lst1.Column(1)
Me.txt2 = Me.lst1.Column(3)
Me.txt3 = Me.lst1.Column(5)
Me.txt4 = Me.lst1.Column(7)
Call ShowFSub(1)
DoCmd.Echo True
End Sub
Private Sub btn1_Click()
DoCmd.Echo False
Call init
DoCmd.Echo True
End Sub
Private Sub btn2_Click()
DoCmd.Echo False
Call init
Me.Tag = CSUB(1)(2)
With Me("FSUB1")
.SourceObject = "FS2"
.Visible = True
.SetFocus
.Form.txt1.SetFocus
End With
Me.Tag = ""
DoCmd.Echo True
End Sub
Private Sub initCnst()
CSUB(1) = Array("txt1", "受付ID", "1,T受付2,受付日付,担当者,受付ID,")
CSUB(2) = Array("txt2", "見積ID", "2,T見積2,見積日付,見積内容,見積ID,受付ID")
CSUB(3) = Array("txt3", "契約ID", "3,T契約2,契約日付,契約内容,契約ID,見積ID")
CSUB(4) = Array("txt4", "完了ID", "4,T完了2,完了日付,完了内容,完了ID,契約ID")
End Sub
Public Function GetMyFilter(iNum As Integer) As String
Dim s As String
GetMyFilter = ""
s = Me(CSUB(iNum)(0))
If (Len(s) > 0) Then
GetMyFilter = CSUB(iNum)(1) & " = " & s
End If
End Function
Public Function GetMyParentItem(iNum As Integer) As Long
Dim i As Integer
Dim s As String
GetMyParentItem = 0
i = iNum - 1
If (i > 0) Then
s = Me(CSUB(i)(0))
If (Len(s) = 0) Then
GetMyParentItem = 0
Else
GetMyParentItem = CLng(s)
End If
End If
End Function
Public Sub NewMyItemReset(iNum As Integer)
Dim i As Integer
If (Len(Me(CSUB(iNum)(0))) = 0) Then Exit Sub
DoCmd.Echo False
For i = iNum To 4
Me("txt" & i) = ""
Next
For i = iNum + 1 To 4
With Me("FSUB" & i)
.Visible = False
.SourceObject = ""
End With
Next
DoCmd.Echo True
End Sub
Public Sub NewMyItemSet(iNum As Integer, iSrc As Long)
Dim sTxt As String
DoCmd.Echo False
sTxt = CSUB(iNum)(0)
If (Me(sTxt) <> iSrc) Then
Me(sTxt) = iSrc
Me.lst1 = IdMake(Me.txt1.Value, Me.txt2.Value, Me.txt3.Value, Me.txt4.Value)
End If
Me.lst1.Requery
Call ShowFSub(iNum)
With Me("FSUB" & Choose(iNum, 2, 3, 4, 1))
.SetFocus
.Form.txt1.SetFocus
End With
DoCmd.Echo True
End Sub
Public Sub ReShow(iNum As Integer)
DoCmd.Echo False
Call lst1_Click
With Me("FSUB" & iNum)
.SetFocus
.Form.txt1.SetFocus
End With
DoCmd.Echo True
End Sub
Private Sub ShowFSub(iNum As Integer)
Dim i As Integer
Dim bShow As Boolean
bShow = True
For i = iNum To 4
With Me("FSUB" & i)
If (bShow) Then
Me.Tag = CSUB(i)(2)
.SourceObject = "FS2"
.Visible = True
If (Len(Me(CSUB(i)(0))) = 0) Then bShow = False
Else
.Visible = False
.SourceObject = ""
End If
End With
Next
Me.Tag = ""
End Sub
Private Sub init()
Dim i As Integer
Me.lst1 = Null
Me.lst1.Requery
For i = 1 To 4
Me("txt" & i) = ""
With Me("FSUB" & i)
.Visible = False
.SourceObject = ""
End With
Next
End Sub
Private Sub Form_Load()
Call initCnst
Call init
End Sub
Private Sub lst1_Click()
DoCmd.Echo False
Me.txt1 = Me.lst1.Column(1)
Me.txt2 = Me.lst1.Column(3)
Me.txt3 = Me.lst1.Column(5)
Me.txt4 = Me.lst1.Column(7)
Call ShowFSub(1)
DoCmd.Echo True
End Sub
Private Sub btn1_Click()
DoCmd.Echo False
Call init
DoCmd.Echo True
End Sub
Private Sub btn2_Click()
DoCmd.Echo False
Call init
Me.Tag = CSUB(1)(2)
With Me("FSUB1")
.SourceObject = "FS2"
.Visible = True
.SetFocus
.Form.txt1.SetFocus
End With
Me.Tag = ""
DoCmd.Echo True
End Sub
多分、うまく説明できていないと思います。
まあ、チョコチョコといじってみてください。
今回1つのフォームを4つのサブフォームコントロールで使いまわししてみましたが、
個々のフォームを作った方が処理は考えやすいし、、早く作成できると思います。
サンプルは以下 | ||||||||||||
| ||||||||||||
※ ファイルは zip 形式 | ||||||||||||
※ 2007 以外は、2007 保存時に変換 & 各バージョンで動作確認 & 最適化 |
- 関連記事
-
- 帳票フォームで帯入力 (2011/12/04)
- どの方法が良いのだろう (2012/05/14)
- コンボ vs リスト vs メイン/サブ (2012/04/09)
- 同時入力したい (2013/09/08)
- 出力項目指定の模索 (2013/04/06)
- 想定外・・・ (2011/06/15)
- 視覚的フォームの模索 (2013/09/03)
- Excel への自力出力例(行・縦計算式挿入) (2012/10/09)
- 帳票サブフォーム間の同期 (2012/08/01)
- 大量なデータはどうする (2011/11/26)
- 営業日のカウント (2014/04/06)
- リストボックス操作の模索 (2012/03/31)
- Excel VBA をやってみた その16 (2015/05/26)
2011/10/10
Category: サンプルかな
« 更新できないクエリでどうにか
サブフォームのFilter »
この記事に対するコメント
トラックバック
| h o m e |