帳票 + 3つのコンボ変則連携 + α
標題変更: 帳票 + 3つのコンボ連携 + α → 帳票 + 3つのコンボ変則連携 + α
記事化が、ずっと、ず~っと延び延びになっていたものです。
帳票フォームになりますが・・・(画面が結構ちらつくので・・・)
やってみた(レベル)という事に・・・
基本的なテーブルは4つで、リレーションシップの雰囲気(実際には設定していませんが)は


となってます。
これを元に、帳票フォームを組み立てると、見た目


になりますが、「コード」「業種」「業態」部分を連携した操作に・・・・
「業種」を設定すれば、他の「コード」「業態」ではその「業種」に絞り込んだ表示に・・・
帳票フォームなので、他レコードの表示に影響がない様にコントロールを重ねる事をします。
過去にも記事にしてたかな・・・・重ねる
今回は3段重ねあり・・・・で


+α として、Excel 1シートに、複数の結果をエクスポートするには・・・・
エクスポートもどきになるのですが、割り当てている業種ごとに並べて出力しましょうか・・・



テーブルを作る


「**ID」部分は、全てオートナンバにしてみました。
サンプルデータを作るのは「Module1」に以下を用意しました。
Public Sub MakeTableData()
Dim cn As ADODB.Connection
Dim rs As New ADODB.Recordset
Dim rs1 As New ADODB.Recordset
Dim rs2 As New ADODB.Recordset
Dim iMojiBase As Integer
Dim i As Long, j As Long, k As Long
Dim sS As String
Dim iAry() As Long
Set cn = CurrentProject.Connection
cn.Execute "DELETE * FROM T企業;"
cn.Execute "DELETE * FROM T業種一覧;"
cn.Execute "DELETE * FROM T業種;"
cn.Execute "DELETE * FROM T業態;"
rs.Open "T業種一覧", cn, adOpenKeyset, adLockPessimistic
rs1.Open "T業種", cn, adOpenKeyset, adLockOptimistic
rs2.Open "T業態", cn, adOpenKeyset, adLockOptimistic
iMojiBase = Asc("a")
For i = 0 To 23
sS = ""
For j = 1 To 3
sS = sS & Chr(iMojiBase + i + j - 1)
Next
rs1.AddNew
rs1(1) = sS
rs1.Update
Next
iMojiBase = Asc("A")
For i = 0 To 25
sS = ""
For j = 1 To 5
sS = sS & Chr(iMojiBase + i)
Next
rs2.AddNew
rs2(1) = sS
rs2.Update
Next
Randomize
ReDim iAry(1 To rs1.AbsolutePosition)
rs2.MoveFirst
While (Not rs2.EOF)
If (Int(1000 * Rnd()) > 500) Then
For i = 1 To UBound(iAry)
iAry(i) = i
Next
For i = 0 To Int(5 * Rnd())
j = Int((UBound(iAry) - i) * Rnd()) + 1
rs1.AbsolutePosition = iAry(j)
iAry(j) = iAry(UBound(iAry) - i)
rs.AddNew
rs(1) = rs1(0)
rs(2) = rs2(0)
rs.Update
Next
End If
rs2.MoveNext
Wend
rs1.Close
rs2.Close
k = rs.AbsolutePosition
iMojiBase = Asc("A")
rs1.Open "T企業", cn, adOpenForwardOnly, adLockOptimistic
For i = 1 To 20
rs.AbsolutePosition = Int(k * Rnd()) + 1
sS = ""
For j = 0 To Int(8 * Rnd())
sS = sS & Chr(iMojiBase + Int(26 * Rnd()))
Next
rs1.AddNew
rs1(1) = sS
rs1(2) = rs(0)
rs1.Update
Next
rs1.Close
rs.Close
Set cn = Nothing
End Sub
Dim cn As ADODB.Connection
Dim rs As New ADODB.Recordset
Dim rs1 As New ADODB.Recordset
Dim rs2 As New ADODB.Recordset
Dim iMojiBase As Integer
Dim i As Long, j As Long, k As Long
Dim sS As String
Dim iAry() As Long
Set cn = CurrentProject.Connection
cn.Execute "DELETE * FROM T企業;"
cn.Execute "DELETE * FROM T業種一覧;"
cn.Execute "DELETE * FROM T業種;"
cn.Execute "DELETE * FROM T業態;"
rs.Open "T業種一覧", cn, adOpenKeyset, adLockPessimistic
rs1.Open "T業種", cn, adOpenKeyset, adLockOptimistic
rs2.Open "T業態", cn, adOpenKeyset, adLockOptimistic
iMojiBase = Asc("a")
For i = 0 To 23
sS = ""
For j = 1 To 3
sS = sS & Chr(iMojiBase + i + j - 1)
Next
rs1.AddNew
rs1(1) = sS
rs1.Update
Next
iMojiBase = Asc("A")
For i = 0 To 25
sS = ""
For j = 1 To 5
sS = sS & Chr(iMojiBase + i)
Next
rs2.AddNew
rs2(1) = sS
rs2.Update
Next
Randomize
ReDim iAry(1 To rs1.AbsolutePosition)
rs2.MoveFirst
While (Not rs2.EOF)
If (Int(1000 * Rnd()) > 500) Then
For i = 1 To UBound(iAry)
iAry(i) = i
Next
For i = 0 To Int(5 * Rnd())
j = Int((UBound(iAry) - i) * Rnd()) + 1
rs1.AbsolutePosition = iAry(j)
iAry(j) = iAry(UBound(iAry) - i)
rs.AddNew
rs(1) = rs1(0)
rs(2) = rs2(0)
rs.Update
Next
End If
rs2.MoveNext
Wend
rs1.Close
rs2.Close
k = rs.AbsolutePosition
iMojiBase = Asc("A")
rs1.Open "T企業", cn, adOpenForwardOnly, adLockOptimistic
For i = 1 To 20
rs.AbsolutePosition = Int(k * Rnd()) + 1
sS = ""
For j = 0 To Int(8 * Rnd())
sS = sS & Chr(iMojiBase + Int(26 * Rnd()))
Next
rs1.AddNew
rs1(1) = sS
rs1(2) = rs(0)
rs1.Update
Next
rs1.Close
rs.Close
Set cn = Nothing
End Sub
業種は、連続した英小文字(3文字)
業態は、同じ英大文字(5文字)
sS = ""
For j = 1 To 5
sS = sS & Chr(iMojiBase + i)
Next
部分は、For j = 1 To 5
sS = sS & Chr(iMojiBase + i)
Next
sS = String(5, iMojiBase + i)
が良かったかも・・・結果は同じになります。
で、これらを使って、「T業種一覧」をソコソコ作っておいて、「T企業」もソコソコに・・・
サンプルデータはこんな感じで、ソコソコに・・・・
「T業種一覧」の各IDでは、元テーブルをコンボボックスでルックアップする様に設定しておきます。
例えば、「業種ID」では、
値集合タイプ: テーブル/クエリ
値集合ソース: T業種
連結列: 1
列数: 2
列幅: 0cm;3cm (IDではなく、業種を見せるように)
入力チェック: はい
値集合ソース: T業種
連結列: 1
列数: 2
列幅: 0cm;3cm (IDではなく、業種を見せるように)
入力チェック: はい
また、「T企業」の「コード」部分では、
値集合タイプ: テーブル/クエリ
値集合ソース: SELECT T業種一覧.コード, T業種.業種, T業態.業態 FROM
(T業種一覧 INNER JOIN T業種 ON T業種一覧.業種ID=T業種.業種ID)
INNER JOIN T業態 ON T業種一覧.業態ID=T業態.業態ID;
連結列: 1
列数: 3
列見出し: はい
列幅: 1.501cm;2cm;2cm (コードを見せるように:Dropdown 時には全部見せるように )
入力チェック: はい
値集合ソース: SELECT T業種一覧.コード, T業種.業種, T業態.業態 FROM
(T業種一覧 INNER JOIN T業種 ON T業種一覧.業種ID=T業種.業種ID)
INNER JOIN T業態 ON T業種一覧.業態ID=T業態.業態ID;
連結列: 1
列数: 3
列見出し: はい
列幅: 1.501cm;2cm;2cm (コードを見せるように:Dropdown 時には全部見せるように )
入力チェック: はい
フォームを作る
フォームウィザードを使った方が(大まかなものを)簡単に作れるので、
以下の様な感じで、仮のクエリ「Q1」を作って、それを元にフォームを作ります。

フォームが出来上がったら、レコードソース部分をクエリ「Q1」のSQLに置換え、クエリ「Q1」を削除します。(私の場合は、こんな感じの手順でするという事で・・・・)
この手順・・・、どこに利点があるのか・・・考えてみてください。(・・・ ないかも)
※ 上記クエリを使ってフォームを作ると、「業種」「業態」部分は ID 付きになるので、
ラベル部分だけから ID の文字を削除しておきます。
また、表示を見ながら、各コントロールのサイズ等、調整しておきます。
(2007 で最初作っているので、最後に「レイアウトの調整」から解除しておきます)
さて、ここからですが・・・このフォームのまま操作してみると、
・既に登録されているレコードを更新してみる
「業種」「業態」を変更すると、「T業種一覧」の内容が書き変わる
・新規レコードを追加してみる
「業種」「業態」から操作すると、「T業種一覧」に新規レコードとして追加される
「コード」から操作すると、既存のものを選択できるが、
その後で、「業種」「業態」を変更すると、「T業種一覧」の内容が書き変わる
つまり、現状では、「業種」「業態」を操作して、「T業種一覧」から選択する・・・
この操作が出来ない。。。。
ここから「コード」「業種」「業態」の連携を考えていきます。

1)現状の「コード」「業種」「業態」は、見るだけにする。
2)操作は、非連結の最背面に配置したコンボボックスで・・・・
最背面に重ねて配置した非連結コントロールは、フォーカスを得ると前面に・・・
また、フォーカスがなくなると元の位置(最背面)に移動する・・・
(背面に居る時には、重ねているので、それ自体は見えない)
この動きを使っていく事になります。
「コード」「業種」「業態」に重ねて、最背面に配置するものを作成します。
「コード」「業種」「業態」を選択し、コピー&貼り付け
名前を順に、「cbx0」「cbx1」「cbx2」に変更し、コントロールソースを削除しておきます。
背面に配置したものにフォーカスを移す・・・これは VBA でやりたいと思うので、
「cbx0」「cbx1」「cbx2」の「タブストップ」は「いいえ」とします。
この3つを選択後マウスで移動し、コピー元にうまく重ね、その後、最背面に移動させます。
最背面への移動は、マウス右クリック → 位置 → 最背面へ移動 の手順で・・・
3)操作途中の「業種」「業態」表示は、最前面の非連結テキストボックスで・・・・
基本的には、2)の重ね方で良いのですが1つ問題点が・・・・
「コード」は「業種」「業態」の2つが求まって、初めて決定されるもの・・・
つまり、「コード」が一意に決まっていなければ、途中の操作内容を表示してあげないと・・・
「cbx1」をいじって「コード」が決まっていなければ、「cbx2」を操作するんでしょう・・・
この時、「cbx1」からフォーカスが外れ、最背面に戻ったら・・・何も表示されない・・・
もちろん、見るためだけの「業種」は、「コード」が決まっていないので、空欄のまま・・・
で、今度は「業種」「業態」にテキストボックスを最前面として重ねる事をします。
「業種」「業態」を選択後、コピー&貼り付け
マウス右クリックし、「コントロールの種類の変更」でテキストボックスへ
「業種」「業態」はテキストボックスの下になるので、「タブストップ」は「いいえ」としておきます。
テキストボックス名は「txt1」「txt2」としておきます。
このテキストボックスを最前面に設定してから、「業種」「業態」に綺麗に重ねます。
このテキストボックスの役目は、下に隠れた操作途中の「cbx1」「cbx2」の代わりに文字列を表示する・・・
なので、通常は下にある「業種」「業態」が見えないと困るので、背景スタイルは透明にします。
細工)
・テキストボックスの表示
テキストボックス「txt1」は、後ろに隠れたコンボボックス「cbx1」の表示内容を・・・
ただ、非連結なので、むやみに表示してしまうと、全レコード同じ表示になってしまう。
操作しているレコードだけで表示できれば良いので・・・・
そこで、フォームのヘッダに非表示のテキストボックス「txt0」を設け、
現在の「企業ID」(オートナンバ)を「txt0」に設定するようにします。
この方法は、カレント行に色を付ける・・・・の、基本的方法ですね。
タイミングとしては、「レコード移動時」「取り消し時」と「挿入前処理」の直後・・・・
( 2000 には「取り消し時」は無いので、意図通りには動きません)
新規レコード追加時のオートナンバは「挿入前処理」を戻った後に採番されるようです。
なので、「タイマー時」を 10ms で利用した「企業ID」→「txt0」設定に・・・
「レコード移動時」「取り消し時」でも同じ動きをさせるように、「タイマー時」を利用。
テキストボックス「txt1」のコントロールソースに以下を設定
=CheckView1(Nz([企業ID]))
で、その関数の処理は
Private Sub Form_Timer()
Me.TimerInterval = 0
Me.txt0 = Me.企業ID
End Sub
Private Function CheckView1(iNum As Long) As String
On Error Resume Next
CheckView1 = ""
If (Nz(Me.txt0) = iNum) Then CheckView1 = Me.cbx1.Column(1)
End Function
Private Function CheckView2(iNum As Long) As String
On Error Resume Next
CheckView2 = ""
If (Nz(Me.txt0) = iNum) Then CheckView2 = Me.cbx2.Column(1)
End Function
Private Sub Form_Current()
' 他処理
' ・・・・
Me.TimerInterval = 10
End Sub
Private Sub Form_Undo(Cancel As Integer)
' 他処理
' ・・・・
Me.TimerInterval = 10
End Sub
Private Sub Form_BeforeInsert(Cancel As Integer)
Me.TimerInterval = 10
End Sub
Me.TimerInterval = 0
Me.txt0 = Me.企業ID
End Sub
Private Function CheckView1(iNum As Long) As String
On Error Resume Next
CheckView1 = ""
If (Nz(Me.txt0) = iNum) Then CheckView1 = Me.cbx1.Column(1)
End Function
Private Function CheckView2(iNum As Long) As String
On Error Resume Next
CheckView2 = ""
If (Nz(Me.txt0) = iNum) Then CheckView2 = Me.cbx2.Column(1)
End Function
Private Sub Form_Current()
' 他処理
' ・・・・
Me.TimerInterval = 10
End Sub
Private Sub Form_Undo(Cancel As Integer)
' 他処理
' ・・・・
Me.TimerInterval = 10
End Sub
Private Sub Form_BeforeInsert(Cancel As Integer)
Me.TimerInterval = 10
End Sub
・操作用コンボボックス
デザイン上で「cbx0」「cbx1」「cbx2」を作った時、「値集合ソース」は変更していなかったので、
「値集合ソース」に設定する SQL を定義し、フォームの「読み込み時」に設定します。
(動的に変更するものではないので、デザイン上で設定しても良いけど・・・)
Const CSQL0 As String = "SELECT Q1.コード, Q1.業種ID, Q2.業種, Q1.業態ID, Q3.業態 " _
& "FROM (T業種一覧 AS Q1 INNER JOIN T業種 AS Q2 ON Q1.業種ID = Q2.業種ID) " _
& "INNER JOIN T業態 AS Q3 ON Q1.業態ID = Q3.業態ID " _
& "WHERE IIF(IsNull([cbx1]),True,Q1.業種ID=[cbx1]) AND " _
& "IIF(IsNull([cbx2]),True,Q1.業態ID=[cbx2]);"
Const CSQL1 As String = "SELECT * FROM T業種 WHERE 業種ID IN " _
& "(SELECT 業種ID FROM T業種一覧 WHERE IIF(IsNull([cbx2]),True,業態ID=[cbx2]));"
Const CSQL2 As String = "SELECT * FROM T業態 WHERE 業態ID IN " _
& "(SELECT 業態ID FROM T業種一覧 WHERE IIF(IsNull([cbx1]),True,業種ID=[cbx1]));"
Private Sub Form_Load()
Me.cbx1 = Null
Me.cbx2 = Null
Me.cbx0 = Null
Me.cbx0.RowSource = CSQL0
Me.cbx1.RowSource = CSQL1
Me.cbx2.RowSource = CSQL2
Me.cbx1.AfterUpdate = "=cbx12Change()"
Me.cbx2.AfterUpdate = "=cbx12Change()"
End Sub
ここで、他のコンボを参照する際、コントロール名だけで十分です。& "FROM (T業種一覧 AS Q1 INNER JOIN T業種 AS Q2 ON Q1.業種ID = Q2.業種ID) " _
& "INNER JOIN T業態 AS Q3 ON Q1.業態ID = Q3.業態ID " _
& "WHERE IIF(IsNull([cbx1]),True,Q1.業種ID=[cbx1]) AND " _
& "IIF(IsNull([cbx2]),True,Q1.業態ID=[cbx2]);"
Const CSQL1 As String = "SELECT * FROM T業種 WHERE 業種ID IN " _
& "(SELECT 業種ID FROM T業種一覧 WHERE IIF(IsNull([cbx2]),True,業態ID=[cbx2]));"
Const CSQL2 As String = "SELECT * FROM T業態 WHERE 業態ID IN " _
& "(SELECT 業態ID FROM T業種一覧 WHERE IIF(IsNull([cbx1]),True,業種ID=[cbx1]));"
Private Sub Form_Load()
Me.cbx1 = Null
Me.cbx2 = Null
Me.cbx0 = Null
Me.cbx0.RowSource = CSQL0
Me.cbx1.RowSource = CSQL1
Me.cbx2.RowSource = CSQL2
Me.cbx1.AfterUpdate = "=cbx12Change()"
Me.cbx2.AfterUpdate = "=cbx12Change()"
End Sub
コントロール名だけの記述にしておくと、
・1つのフォームとして表示・・・・
・サブフォームとして組み込み・・・・
どちらでも動くものになります。
ただ、フォームのレコードソース部分での記述では、自フォームにあるコントロールでも
Forms!フォーム名!コントロール名
と記述しないといけないみたい(?嘘かも)ですが・・・・
「業種」「業態」の操作用途にあたる「cbx1」「cbx2」の「更新後処理」では、
設定により「コード」(「cbx0」)が一意になるか・・・・これをチェックします。
Private Function cbx12Change()
With Me.cbx0
.Requery
If ((.ListCount + .ColumnHeads) = 1) Then
.Value = .ItemData(.ListCount - 1)
Me.cbx1 = CLng(Me.cbx0.Column(1))
Me.cbx2 = CLng(Me.cbx0.Column(3))
Me.コード = .Value
Else
.Value = Null
If (Not IsNull(Me.コード)) Then Me.コード = Null
End If
End With
End Function
まず、With Me.cbx0
.Requery
If ((.ListCount + .ColumnHeads) = 1) Then
.Value = .ItemData(.ListCount - 1)
Me.cbx1 = CLng(Me.cbx0.Column(1))
Me.cbx2 = CLng(Me.cbx0.Column(3))
Me.コード = .Value
Else
.Value = Null
If (Not IsNull(Me.コード)) Then Me.コード = Null
End If
End With
End Function
・「cbx1」「cbx2」の変更により、「cbx0」の表示が1件になるか? これを確認します。
・1件・・・・これの判別は、(.ListCount + .ColumnHeads) = 1 で。
「列見出し」を「はい」としていると、1件でも ListCount は2となります。
つまり、列見出しの文字列部分も ListCount 内でカウントされているようです。
なので、列見出しがあった場合、 ColumnHeads は True( -1 )なので数値として利用しています。
・で、1件ならその値を設定し、それに伴い「cbx1」「cbx2」へ値を設定し直します。
1件にならなければ、Null を設定しておいて・・・・
もし、更新操作で「コード」が設定されていたのなら、見る側の「コード」も Null へ・・・
・フォーカスの移動
「コード」「業種」「業態」部分はコントロールを重ねているので、
マウスでクリックできるのは、前面の「コード」「txt1」「txt2」になります。
これにフォーカスが入ろうとした場合、最背面に配置した操作用のコントロールにフォーカスを移します。
フォーカスが移されてくる先はコンボボックスなので、Requery し Dropdown 表示するようにします。
例えば、
Private Sub txt1_Enter()
Me.cbx1.SetFocus
End Sub
Private Sub cbx1_Enter()
Me.cbx1.Requery
End Sub
Private Sub cbx1_GotFocus()
Me.cbx1.Dropdown
End Sub
Me.cbx1.SetFocus
End Sub
Private Sub cbx1_Enter()
Me.cbx1.Requery
End Sub
Private Sub cbx1_GotFocus()
Me.cbx1.Dropdown
End Sub
※ サンプルファイルでは、
テキストボックスの幅が小さく、下のコンボボックス(見るだけ用途)がクリックできちゃいます。
これは間違いで、本来はコンボボックスの幅と同じ・・・が良いです。
動作確認時には、表示されているところ・・・下三角マークじゃない所をクリックしてください。
こんな感じで、処理を組み立てていきます。
記述した全部は以下
Const CSQL0 As String = "SELECT Q1.コード, Q1.業種ID, Q2.業種, Q1.業態ID, Q3.業態 " _
& "FROM (T業種一覧 AS Q1 INNER JOIN T業種 AS Q2 ON Q1.業種ID = Q2.業種ID) " _
& "INNER JOIN T業態 AS Q3 ON Q1.業態ID = Q3.業態ID " _
& "WHERE IIF(IsNull([cbx1]),True,Q1.業種ID=[cbx1]) AND " _
& "IIF(IsNull([cbx2]),True,Q1.業態ID=[cbx2]);"
Const CSQL1 As String = "SELECT * FROM T業種 WHERE 業種ID IN " _
& "(SELECT 業種ID FROM T業種一覧 WHERE IIF(IsNull([cbx2]),True,業態ID=[cbx2]));"
Const CSQL2 As String = "SELECT * FROM T業態 WHERE 業態ID IN " _
& "(SELECT 業態ID FROM T業種一覧 WHERE IIF(IsNull([cbx1]),True,業種ID=[cbx1]));"
Private Sub Form_Timer()
Me.TimerInterval = 0
Me.txt0 = Me.企業ID
End Sub
Private Function CheckView1(iNum As Long) As String
On Error Resume Next
CheckView1 = ""
If (Nz(Me.txt0) = iNum) Then CheckView1 = Me.cbx1.Column(1)
End Function
Private Function CheckView2(iNum As Long) As String
On Error Resume Next
CheckView2 = ""
If (Nz(Me.txt0) = iNum) Then CheckView2 = Me.cbx2.Column(1)
End Function
Private Sub Form_Load()
Me.cbx1 = Null
Me.cbx2 = Null
Me.cbx0 = Null
Me.cbx0.RowSource = CSQL0
Me.cbx1.RowSource = CSQL1
Me.cbx2.RowSource = CSQL2
Me.cbx1.AfterUpdate = "=cbx12Change()"
Me.cbx2.AfterUpdate = "=cbx12Change()"
End Sub
Private Sub Form_Current()
Me.cbx1 = Null
Me.cbx2 = Null
Me.cbx0.Requery
If (IsNull(Me.コード)) Then
Me.cbx0 = Null
Else
Me.cbx0 = Me.コード
Me.cbx1 = CLng(Me.cbx0.Column(1))
Me.cbx2 = CLng(Me.cbx0.Column(3))
End If
Me.TimerInterval = 10
End Sub
Private Sub Form_Undo(Cancel As Integer)
Me.cbx1 = Null
Me.cbx2 = Null
Me.cbx0.Requery
If (IsNull(Me.コード.OldValue)) Then
Me.cbx0 = Null
Else
Me.cbx0 = Me.コード.OldValue
Me.cbx1 = CLng(Me.cbx0.Column(1))
Me.cbx2 = CLng(Me.cbx0.Column(3))
End If
Me.cbx1.Requery
Me.cbx2.Requery
Me.TimerInterval = 10
End Sub
Private Sub Form_BeforeInsert(Cancel As Integer)
Me.TimerInterval = 10
End Sub
Private Sub コード_Enter()
Me.cbx0.SetFocus
End Sub
Private Sub cbx0_Enter()
Me.cbx0.Requery
End Sub
Private Sub cbx0_GotFocus()
Me.cbx0.Dropdown
End Sub
Private Sub cbx0_AfterUpdate()
Me.コード = Me.cbx0
If (IsNull(Me.cbx0)) Then
Me.cbx1 = Null
Me.cbx2 = Null
Else
Me.cbx1 = CLng(Me.cbx0.Column(1))
Me.cbx2 = CLng(Me.cbx0.Column(3))
End If
End Sub
Private Function cbx12Change()
With Me.cbx0
.Requery
If ((.ListCount + .ColumnHeads) = 1) Then
.Value = .ItemData(.ListCount - 1)
Me.cbx1 = CLng(Me.cbx0.Column(1))
Me.cbx2 = CLng(Me.cbx0.Column(3))
Me.コード = .Value
Else
.Value = Null
If (Not IsNull(Me.コード)) Then Me.コード = Null
End If
End With
End Function
Private Sub txt1_Enter()
Me.cbx1.SetFocus
End Sub
Private Sub cbx1_Enter()
Me.cbx1.Requery
End Sub
Private Sub cbx1_GotFocus()
Me.cbx1.Dropdown
End Sub
Private Sub txt2_Enter()
Me.cbx2.SetFocus
End Sub
Private Sub cbx2_Enter()
Me.cbx2.Requery
End Sub
Private Sub cbx2_GotFocus()
Me.cbx2.Dropdown
End Sub
Private Sub btn1_Click()
Call ShowExcel
End Sub
& "FROM (T業種一覧 AS Q1 INNER JOIN T業種 AS Q2 ON Q1.業種ID = Q2.業種ID) " _
& "INNER JOIN T業態 AS Q3 ON Q1.業態ID = Q3.業態ID " _
& "WHERE IIF(IsNull([cbx1]),True,Q1.業種ID=[cbx1]) AND " _
& "IIF(IsNull([cbx2]),True,Q1.業態ID=[cbx2]);"
Const CSQL1 As String = "SELECT * FROM T業種 WHERE 業種ID IN " _
& "(SELECT 業種ID FROM T業種一覧 WHERE IIF(IsNull([cbx2]),True,業態ID=[cbx2]));"
Const CSQL2 As String = "SELECT * FROM T業態 WHERE 業態ID IN " _
& "(SELECT 業態ID FROM T業種一覧 WHERE IIF(IsNull([cbx1]),True,業種ID=[cbx1]));"
Private Sub Form_Timer()
Me.TimerInterval = 0
Me.txt0 = Me.企業ID
End Sub
Private Function CheckView1(iNum As Long) As String
On Error Resume Next
CheckView1 = ""
If (Nz(Me.txt0) = iNum) Then CheckView1 = Me.cbx1.Column(1)
End Function
Private Function CheckView2(iNum As Long) As String
On Error Resume Next
CheckView2 = ""
If (Nz(Me.txt0) = iNum) Then CheckView2 = Me.cbx2.Column(1)
End Function
Private Sub Form_Load()
Me.cbx1 = Null
Me.cbx2 = Null
Me.cbx0 = Null
Me.cbx0.RowSource = CSQL0
Me.cbx1.RowSource = CSQL1
Me.cbx2.RowSource = CSQL2
Me.cbx1.AfterUpdate = "=cbx12Change()"
Me.cbx2.AfterUpdate = "=cbx12Change()"
End Sub
Private Sub Form_Current()
Me.cbx1 = Null
Me.cbx2 = Null
Me.cbx0.Requery
If (IsNull(Me.コード)) Then
Me.cbx0 = Null
Else
Me.cbx0 = Me.コード
Me.cbx1 = CLng(Me.cbx0.Column(1))
Me.cbx2 = CLng(Me.cbx0.Column(3))
End If
Me.TimerInterval = 10
End Sub
Private Sub Form_Undo(Cancel As Integer)
Me.cbx1 = Null
Me.cbx2 = Null
Me.cbx0.Requery
If (IsNull(Me.コード.OldValue)) Then
Me.cbx0 = Null
Else
Me.cbx0 = Me.コード.OldValue
Me.cbx1 = CLng(Me.cbx0.Column(1))
Me.cbx2 = CLng(Me.cbx0.Column(3))
End If
Me.cbx1.Requery
Me.cbx2.Requery
Me.TimerInterval = 10
End Sub
Private Sub Form_BeforeInsert(Cancel As Integer)
Me.TimerInterval = 10
End Sub
Private Sub コード_Enter()
Me.cbx0.SetFocus
End Sub
Private Sub cbx0_Enter()
Me.cbx0.Requery
End Sub
Private Sub cbx0_GotFocus()
Me.cbx0.Dropdown
End Sub
Private Sub cbx0_AfterUpdate()
Me.コード = Me.cbx0
If (IsNull(Me.cbx0)) Then
Me.cbx1 = Null
Me.cbx2 = Null
Else
Me.cbx1 = CLng(Me.cbx0.Column(1))
Me.cbx2 = CLng(Me.cbx0.Column(3))
End If
End Sub
Private Function cbx12Change()
With Me.cbx0
.Requery
If ((.ListCount + .ColumnHeads) = 1) Then
.Value = .ItemData(.ListCount - 1)
Me.cbx1 = CLng(Me.cbx0.Column(1))
Me.cbx2 = CLng(Me.cbx0.Column(3))
Me.コード = .Value
Else
.Value = Null
If (Not IsNull(Me.コード)) Then Me.コード = Null
End If
End With
End Function
Private Sub txt1_Enter()
Me.cbx1.SetFocus
End Sub
Private Sub cbx1_Enter()
Me.cbx1.Requery
End Sub
Private Sub cbx1_GotFocus()
Me.cbx1.Dropdown
End Sub
Private Sub txt2_Enter()
Me.cbx2.SetFocus
End Sub
Private Sub cbx2_Enter()
Me.cbx2.Requery
End Sub
Private Sub cbx2_GotFocus()
Me.cbx2.Dropdown
End Sub
Private Sub btn1_Click()
Call ShowExcel
End Sub
+α として、Excel 1シートに、複数の結果をエクスポートするには・・・・
これは、おまけ的なものになります。
私は、ほとんど Access のレポート機能は使えません。
データの再利用/自由な縮尺・・・等考えると、直接 Excel に・・・・
Excel に出力する・・・・穴埋め的なもの等あるので、DoCmd 系のものは使いません。
自分で組めば、同一シートに複数のクエリの結果表示・・・・容易です。
(穴埋め的なものは、コード量は増えますけど・・・・)
処理の概要としては、
「T企業」に登録してある企業一覧を表示する際、業種別に表示してみましょうか。
業種別・・・・
業種でソートすれば終わりじゃないの・・・・・と言われれば、そこで終わるんですが
業種が変わったら、空白行を入れたい・・・・
(これも Excel に転記した後、Excel 側を順次チェックして、空白行を INSERT ・・・でも可能ですが)
また、もう1度フィールド名を表示したい・・・・
とかを、(無駄に)想定したものになります。
共通に使える関数を用意しておいて
Private Sub ExcelPrint(ws As Object, rs As ADODB.Recordset, sQ As String _
, Optional iSkip As Long = 1 _
, Optional bHead As Boolean = False)
Dim iRow As Long
Dim i As Long
Const xlCellTypeLastCell = 11
Const xlCenter = -4108
If (iSkip < 0) Then
iRow = 1
Else
iRow = ws.UsedRange.SpecialCells(xlCellTypeLastCell).Row + iSkip + 1
End If
With ws.Cells(iRow, 1)
If (bHead) Then
For i = 0 To rs.Fields.Count - 1
.Offset(, i + 1) = rs(i).Name
Next
.EntireRow.HorizontalAlignment = xlCenter
iRow = iRow + 1
End If
End With
ws.Cells(iRow, 1) = sQ
ws.Cells(iRow, 2).CopyFromRecordset rs
End Sub
, Optional iSkip As Long = 1 _
, Optional bHead As Boolean = False)
Dim iRow As Long
Dim i As Long
Const xlCellTypeLastCell = 11
Const xlCenter = -4108
If (iSkip < 0) Then
iRow = 1
Else
iRow = ws.UsedRange.SpecialCells(xlCellTypeLastCell).Row + iSkip + 1
End If
With ws.Cells(iRow, 1)
If (bHead) Then
For i = 0 To rs.Fields.Count - 1
.Offset(, i + 1) = rs(i).Name
Next
.EntireRow.HorizontalAlignment = xlCenter
iRow = iRow + 1
End If
End With
ws.Cells(iRow, 1) = sQ
ws.Cells(iRow, 2).CopyFromRecordset rs
End Sub
どのワークシートに、このレコードセットの内容を、レコードセットの概要(sQ)、
既にある記述から何行ずらして、フィールドの表示は?
この5つを与えてみます。
A列には、レコードセットの概要・・・・B列以降に、レコードセットの中身を・・・
中では、自分がしたい処理を記述しておけば良いので・・・・・
ワークシート・・・・どの列・・・と言わずに使っている範囲から何行・・・
ws.UsedRange.SpecialCells(xlCellTypeLastCell).Row
を使いましょうか・・・・でも、真っ白な時でも上記では 1 が得られるようで、書き出しが2行目からになってしまう。
なので、1行目からね・・・・を指定させるために iSkip < 0 なら1行目から・・・
で、フィールド名を表示したら、その行は、中央寄せ(HorizontalAlignment = xlCenter)しましょう。
もし、この関数の呼び出し元で、レコードセットを使い回しするとしたら・・・・
CopyFromRecordset により、EOF = True になるみたいなので、注意が必要・・・・
共通の関数は作ったので、関数を呼ぶ側の記述では、
「T業種」に登録されているものすべてを対象に・・・
ではなく、「T企業」に登録されている業種だけを対象にしましょう。
「T企業」をベースに表示したいもの一覧を用意しておいて、
「T企業」に登録されている業種で順繰りに Filter して・・・・
(この部分、複数のクエリで順次レコードセットを得る様にすると・・・同じ事になりますね)
Public Sub ShowExcel()
Dim rsP As New ADODB.Recordset
Dim rs As New ADODB.Recordset
Dim bFirst As Boolean
rsP.Source = "SELECT * FROM T業種 WHERE 業種ID IN " _
& "(SELECT 業種ID FROM T業種一覧 WHERE コード IN " _
& "(SELECT コード FROM T企業)) " _
& "ORDER BY 業種;"
rsP.Open , CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly
If (Not rsP.EOF) Then
rs.Source = "SELECT Q1.企業ID,Q1.企業名, Q3.業種ID,Q3.業種, Q4.業態ID,Q4.業態 FROM T企業 AS Q1 " _
& "INNER JOIN ((T業種一覧 AS Q2 INNER JOIN T業種 AS Q3 ON Q2.業種ID=Q3.業種ID) " _
& "INNER JOIN T業態 AS Q4 ON Q2.業態ID=Q4.業態ID) ON Q1.コード=Q2.コード " _
& "ORDER BY Q3.業種, Q1.企業名, Q4.業態;"
rs.Open , CurrentProject.Connection, adOpenStatic, adLockReadOnly
With CreateObject("Excel.Application")
With .Workbooks.Add
bFirst = True
While (Not rsP.EOF)
rs.Filter = "業種ID = " & rsP("業種ID")
If (bFirst) Then
Call ExcelPrint(.WorkSheets(1), rs, rsP("業種"), -1, True)
Else
Call ExcelPrint(.WorkSheets(1), rs, rsP("業種"))
' Call ExcelPrint(.WorkSheets(1), rs, rsP("業種"), 0)
' Call ExcelPrint(.WorkSheets(1), rs, rsP("業種"), 2, True)
End If
rsP.MoveNext
bFirst = False
Wend
.WorkSheets(1).UsedRange.EntireColumn.AutoFit
End With
.Visible = True
End With
rs.Close
End If
rsP.Close
End Sub
Dim rsP As New ADODB.Recordset
Dim rs As New ADODB.Recordset
Dim bFirst As Boolean
rsP.Source = "SELECT * FROM T業種 WHERE 業種ID IN " _
& "(SELECT 業種ID FROM T業種一覧 WHERE コード IN " _
& "(SELECT コード FROM T企業)) " _
& "ORDER BY 業種;"
rsP.Open , CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly
If (Not rsP.EOF) Then
rs.Source = "SELECT Q1.企業ID,Q1.企業名, Q3.業種ID,Q3.業種, Q4.業態ID,Q4.業態 FROM T企業 AS Q1 " _
& "INNER JOIN ((T業種一覧 AS Q2 INNER JOIN T業種 AS Q3 ON Q2.業種ID=Q3.業種ID) " _
& "INNER JOIN T業態 AS Q4 ON Q2.業態ID=Q4.業態ID) ON Q1.コード=Q2.コード " _
& "ORDER BY Q3.業種, Q1.企業名, Q4.業態;"
rs.Open , CurrentProject.Connection, adOpenStatic, adLockReadOnly
With CreateObject("Excel.Application")
With .Workbooks.Add
bFirst = True
While (Not rsP.EOF)
rs.Filter = "業種ID = " & rsP("業種ID")
If (bFirst) Then
Call ExcelPrint(.WorkSheets(1), rs, rsP("業種"), -1, True)
Else
Call ExcelPrint(.WorkSheets(1), rs, rsP("業種"))
' Call ExcelPrint(.WorkSheets(1), rs, rsP("業種"), 0)
' Call ExcelPrint(.WorkSheets(1), rs, rsP("業種"), 2, True)
End If
rsP.MoveNext
bFirst = False
Wend
.WorkSheets(1).UsedRange.EntireColumn.AutoFit
End With
.Visible = True
End With
rs.Close
End If
rsP.Close
End Sub
で、
Call ExcelPrint(.WorkSheets(1), rs, rsP("業種"))
' Call ExcelPrint(.WorkSheets(1), rs, rsP("業種"), 0)
' Call ExcelPrint(.WorkSheets(1), rs, rsP("業種"), 2, True)
の部分を順に有効にした時の Excel 出力は、以下の様になります。' Call ExcelPrint(.WorkSheets(1), rs, rsP("業種"), 0)
' Call ExcelPrint(.WorkSheets(1), rs, rsP("業種"), 2, True)



この Excel 関係は、「Module2」に記述してあります。
フォームからは、
Private Sub btn1_Click()
Call ShowExcel
End Sub
するだけです。Call ShowExcel
End Sub
今回のサンプルでは、「コード」「業種」「業態」それぞれをいじれるようにしましたが、
通常は、いじれる部分は「コード」だけで、「業種」「業態」はテキストボックスにして、
コントロールソースを、=Me.コード.Column(1) / =Me.コード.Column(2) とかにすると思います。
(もちろん、Me.コード.Column(1) / (2) 部分は、それなりに得られるようにしておく必要あり・・・)
サンプルは以下 | ||||||||||||
| ||||||||||||
※ ファイルは zip 形式 | ||||||||||||
※ 2007 以外は、2007 保存時に変換 & 各バージョンで動作確認 & 最適化 |
※ ( 2000 には「取り消し時」は無いので、その部分は意図通りには動きません)
※ 「cbx0」も非連結にしちゃったけど・・・連結にしていたら、もう少し楽だったのかも・・・
- 関連記事
-
- 再帰処理にはまる(その3) (2012/03/12)
- 文字の抜き出し その2 (2013/09/16)
- Excel VBA をやってみた その9 (2013/12/10)
- Excel VBA をやってみた その7 (2013/09/22)
- Excel VBA をやってみた その11 (2014/08/26)
- Excel VBA をやってみた その3(合計値検索) (2012/04/25)
- 検索急上昇 (2014/07/05)
- Excel VBA をやってみた その5 (2012/10/10)
- 再帰処理にはまる(その2) (2012/03/12)
- 重ねる (2012/05/16)
- 連番の空き先頭を探す (2013/09/13)
- フィールド順 クエリ編 (2011/06/04)
- Excel VBA をやってみた その2 (2012/04/10)
2013/05/05
Category: やってみる
TB: -- /
CM: 0
« 再帰処理にはまる(その5)
通知 »
この記事に対するコメント
| h o m e |