FC2ブログ

スポンサーサイト 


上記の広告は1ヶ月以上更新のないブログに表示されています。
新しい記事を書く事で広告が消せます。

--/--/--

Category: スポンサー広告

TB: --  /  CM: --

top △

サブフォームのFilter 


他記事でも、いろいろとサブフォームを取り上げてきていましたが、
以下のようなテーブルが3つあったとします。

テーブル「T01」
顧客ID会社名
1○○商事
2○○建設

テーブル「T02」
売上ID顧客ID日付
112011/09/30
222011/10/01
312011/09/30
422011/09/30

テーブル「T03」
an売上ID商品名単価数量合計
11 ボールペン\200 \400 
22 鉛筆\20 12 \240 
33 ホッチキスの芯\50 \150 
44 ボールペン(赤)\200 \600 

ここで、サブフォームにテーブル「T03」を帳票フォームで表示して、
親で「顧客ID」「日付」を元に検索した時、条件に合うものならサブフォームに一覧として表示したい。
リンク親/子フィールドを設定していると、サブフォームの表示が1件だけになってしまう。


というのがあった時、リンク親/子フィールドは設定せずに、Filter の設定で実現します。
Filter を設定する際は、
 売上ID IN (SELECT 売上ID FROM T02 WHERE ・・・・)
のように、IN句を使うようにします。

サンプル用フォーム「F_T01」:検索とサブフォーム部分だけの表示
kEnt100_T01

サンプル用フォーム「F_T01A」:「F_T01」に部分一致検索を追加
kEnt100_T01A

サンプル用フォーム「F_T01B」:「F_T01A」を元に親を帳票フォームに
kEnt100_T01B

サンプル用フォーム「F_T01C」:「F_T01B」を元に入力も可能に
kEnt100_T01C
 
質問内容から、実際のデータの細かい取り決めはわかってません。
(テーブル「T02」「T03」の「売上ID」は 一対一? 一対多? 等)
(一対多が出来るように、「T03」にオートナンバ「an」追加しときました)


サブフォーム用「F_T03」の作成

まず、テーブル「T03」を元にフォームウィザードを使って表形式として作成します。
kEnt100_T03
テキストボックス「an」「売上ID」部分はいじらせないので、
「編集ロック」を「はい」、「使用可能」を「いいえ」にしておきます。
また、フォームの「追加の許可」を「いいえ」としておきます。

どこかのレコードを選んだ時、誰の、何時のものなのか表示するように細工しておきます。
非表示のコンボボックス「cbx1」をヘッダー部に配置します。
値集合ソースを
SELECT T02.売上ID, T02.日付, T01.顧客ID, T01.会社名
FROM T01 INNER JOIN T02 ON T01.顧客ID=T02.顧客ID;
列数を 4
連結列を 1
コントロールソースを 売上ID
とします。
その後、会社名を表示するテキストボックス、日にちを表示するテキストボックスを
ヘッダーに配置し、「編集ロック」を「はい」、「使用可能」を「いいえ」にしておきます。
会社名を表示するテキストボックスのコントロールソースに、 =[cbx1].[column](3)
日にちを表示するテキストボックスのコントロールソースに、 =[cbx1].[column](1)
を設定しておきます。

このフォーム「F_T03」はサブフォーム用なので、直接起動できないようにしておきます。
VBAで以下を記述しておきます。
Private Sub Form_Open(Cancel As Integer)
  On Error Resume Next
  Me.Tag = Me.Parent.Tag
  If (Err <> 0) Then Cancel = True
End Sub
(直接起動では Me.Parent の参照でエラーになるのを利用)


フォーム「F_T01」の作成:検索とサブフォーム部分だけの表示

kEnt100_T01
フォームデザインから作成します。
「レコードセレクタ」「移動ボタン」を「いいえ」にしておきます。
顧客を選択する為のコンボボックス「cbx1」を配置します。
値集合ソースを
SELECT T01.顧客ID, T01.会社名 FROM T01;
列数を 2
連結列を 1
日付指定用にテキストボックス「txt1」を配置します。
「実行」「クリア」用にコマンドボタン「btn1」「btn2」を配置します。

出来上がっていたフォーム「F_T03」をその下にドラッグ&ドロップし、
サブフォームとして組み込みます。
組み込んだ際、サブフォームコントロール名を「FSUB」に変更しておきます。
(この「FSUB」は私が良く使う名前なので、そのままでも・・・ただし、VBA記述に注意)

以下VBAを記述します。
Private Sub SetFilter(sS As String)
  With Me.FSUB.Form
    If (Len(sS) = 0) Then
      .FilterOn = False
      .Filter = ""
    Else
      .Filter = sS
      .FilterOn = True
    End If
  End With
End Sub

Private Sub btn1_Click()
  Dim sS As String
  Const sAndOr As String = " AND "

  sS = ""
  If (Not IsNull(Me.cbx1)) Then
    sS = sS & sAndOr & "顧客ID = " & Me.cbx1
  End If
  If (Not IsNull(Me.txt1)) Then
    sS = sS & sAndOr & "日付 = #" & Me.txt1 & "#"
  End If

  If (Len(sS) > 0) Then
    sS = "売上ID IN (SELECT 売上ID FROM T02 WHERE " _
        & Mid(sS, Len(sAndOr) + 1) & ")"
  End If
  Call SetFilter(sS)
End Sub

Private Sub btn2_Click()
  Me.cbx1 = Null
  Me.txt1 = Null
  Call SetFilter("")
End Sub

これで、一通り完成です。


フォーム「F_T01A」の作成:「F_T01」に部分一致検索を追加

フォーム「F_T01」を「F_T01A」名でコピーし、
会社名の部分一致検索用にテキストボックス「txt2」を追加します。
kEnt100_T01AD
検索する際、部分一致指定よりもコンボボックス指定を優先してみると
VBAの記述は以下のようになります。
Private Sub SetFilter(sS As String)
  With Me.FSUB.Form
    If (Len(sS) = 0) Then
      .FilterOn = False
      .Filter = ""
    Else
      .Filter = sS
      .FilterOn = True
    End If
  End With
End Sub

Private Sub btn1_Click()
  Dim sS As String
  Const sAndOr As String = " AND "

  sS = ""
  If (Not IsNull(Me.cbx1)) Then
    Me.txt2 = Null
    sS = sS & sAndOr & "T02.顧客ID = " & Me.cbx1
  ElseIf (Not IsNull(Me.txt2)) Then
    sS = sS & sAndOr & "T01.会社名 Like '*" & Me.txt2 & "*'"
  End If
  If (Not IsNull(Me.txt1)) Then
    sS = sS & sAndOr & "T02.日付 = #" & Me.txt1 & "#"
  End If

  If (Len(sS) > 0) Then
    sS = "売上ID IN (SELECT 売上ID FROM T02 INNER JOIN T01 ON T02.顧客ID = T01.顧客ID WHERE " _
        & Mid(sS, Len(sAndOr) + 1) & ")"
  End If
  Call SetFilter(sS)
End Sub

Private Sub btn2_Click()
  Me.cbx1 = Null
  Me.txt1 = Null
  Me.txt2 = Null
  Call SetFilter("")
End Sub

kEnt100_T01A
これで完成です。さほど、変更はないですね。


フォーム「F_T01B」の作成:「F_T01A」を元に親を帳票フォームに

フォーム「F_T01A」を「F_T01B」名でコピーします。
ここでは、親フォームにはテーブル「T02」を帳票として表示しましょう・・・というものです。
また、サブフォームの表示を、
・検索したら一覧で表示
・親のレコードを選択した時には個別で表示
できるように、動作選択用にオプショングループ「op1」を追加しています。
kEnt100_T01BD
フォームのデザインで、
検索部分のものをヘッダーに移動、サブフォーム部分をフッターに移動
(親が帳票フォームでもヘッダー部にサブフォームを組み込みできるみたいなので・・・)
(ただ、推奨できるものではないと思います。・・・・ということで自己責任で)

詳細部分が空になったので、
別途テーブル「T02」を元にウィザード・表形式で作成したフォームからコピーしてきます。
コピーしたらそのフォームはいらなくなるので、削除しておきます。

※ テーブル「T02」の「顧客ID」部分は、テーブル「T01」をルックアップ設定していたので
  コンボボックスとして作成されました。

「売上ID」は内部採番したいので、「編集ロック」を「はい」、「使用可能」を「いいえ」にしておきます。
最後に、フォームの「追加の許可」を「いいえ」、「既定のビュー」を「帳票フォーム」に変更します。
忘れてました。「レコードセレクタ」を表示するように変更しておきます。
記述したVBAは以下
Private Sub SetFilter(sS As String)
  With Me
    If (Len(sS) = 0) Then
      .FilterOn = False
      .Filter = ""
    ElseIf (InStr(sS, "(") > 0) Then
      .Filter = sS
      .FilterOn = True
    End If
  End With
  With Me.FSUB.Form
    If (Len(sS) = 0) Then
      .FilterOn = False
      .Filter = ""
    Else
      .Filter = sS
      .FilterOn = True
    End If
  End With
End Sub

Private Sub btn1_Click()
  Dim sS As String
  Const sAndOr As String = " AND "

  Me.op1 = 0
  sS = ""
  If (Not IsNull(Me.cbx1)) Then
    Me.txt2 = Null
    sS = sS & sAndOr & "T02.顧客ID = " & Me.cbx1
  ElseIf (Not IsNull(Me.txt2)) Then
    sS = sS & sAndOr & "T01.会社名 Like '*" & Me.txt2 & "*'"
  End If
  If (Not IsNull(Me.txt1)) Then
    sS = sS & sAndOr & "T02.日付 = #" & Me.txt1 & "#"
  End If

  If (Len(sS) > 0) Then
    sS = "売上ID IN (SELECT 売上ID FROM T02 INNER JOIN T01 ON T02.顧客ID = T01.顧客ID WHERE " _
        & Mid(sS, Len(sAndOr) + 1) & ")"
  End If
  Call SetFilter(sS)
End Sub

Private Sub btn2_Click()
  Me.op1 = 0
  Me.cbx1 = Null
  Me.txt1 = Null
  Me.txt2 = Null
  Call SetFilter("")
End Sub

Private Sub SetFilterOne()
  Dim sS As String

  If (Me.Recordset.RecordCount > 0) Then
    sS = "売上ID = " & Me.売上ID
    Call SetFilter(sS)
  End If
End Sub

Private Sub op1_Click()
  Select Case Me.op1
    Case 0
        Call btn1_Click
    Case Else
        Call SetFilterOne
  End Select
End Sub

Private Sub Form_Current()
  If (Me.op1 > 0) Then Call SetFilterOne
End Sub

Filter を設定する時、個別なら "=" を使って1つのみをサブフォームに表示させます。
なので、"=" の場合は親自身に Filter を設定してはいけないルールとしました。
それを判別するのに
    ElseIf (InStr(sS, "(") > 0) Then
としていました。
kEnt100_T01B
これで、完成です。


フォーム「F_T01C」の作成:「F_T01B」を元に入力も可能に

kEnt100_T01C
まず、フォーム「F_T03」を「F_T03C」名でコピーします。
サブフォームからの入力も可能にするために手を入れるので・・・
「F_T03C」を手直ししていきます。
フォームの「追加の許可」を「はい」に変更します。
新規追加の時は、親の「売上ID」が設定されているかで、入力可/不可しながら
設定されていたら、自分のテーブル「T03」用にコピー設定します。
この処理は「挿入前処理」に記述しておきます。
VBAで記述したのは以下が全部
Private Sub Form_Open(Cancel As Integer)
  On Error Resume Next
  Me.Tag = Me.Parent.Tag
  If (Err <> 0) Then Cancel = True
End Sub

Private Sub Form_BeforeInsert(Cancel As Integer)
  If (IsNull(Me.Parent.売上ID)) Then
    Cancel = True
  Else
    Me.売上ID = Me.Parent.売上ID
    Me.cbx1.Requery
  End If
End Sub

新規の時にコンボボックスを Requery しているのは、親の方で顧客が追加されていたら・・・
のために・・・
サブフォームはこれで完成。

次に親のフォームについて

フォーム「F_T01B」を「F_T01C」名でコピーします。
サブフォームコントロールのソースオブジェクトを「F_T03C」に変更します。
フォームの「追加の許可」を「はい」に変更します。
これで、テーブル「T02」の新規データは追加できていきます。
でも、顧客を追加できていないので各コンボボックスの「リスト外入力」を使用します。
VBAで記述したのは以下
Private Sub SetFilter(sS As String)
  With Me
    If (Len(sS) = 0) Then
      .FilterOn = False
      .Filter = ""
    ElseIf (InStr(sS, "(") > 0) Then
      .Filter = sS
      .FilterOn = True
    End If
  End With
  With Me.FSUB.Form
    If (Len(sS) = 0) Then
      .FilterOn = False
      .Filter = ""
    Else
      .Filter = sS
      .FilterOn = True
    End If
  End With
End Sub

Private Sub btn1_Click()
  Dim sS As String
  Const sAndOr As String = " AND "

  Me.op1 = 0
  sS = ""
  If (Not IsNull(Me.cbx1)) Then
    Me.txt2 = Null
    sS = sS & sAndOr & "T02.顧客ID = " & Me.cbx1
  ElseIf (Not IsNull(Me.txt2)) Then
    sS = sS & sAndOr & "T01.会社名 Like '*" & Me.txt2 & "*'"
  End If
  If (Not IsNull(Me.txt1)) Then
    sS = sS & sAndOr & "T02.日付 = #" & Me.txt1 & "#"
  End If

  If (Len(sS) > 0) Then
    sS = "売上ID IN (SELECT 売上ID FROM T02 INNER JOIN T01 ON T02.顧客ID = T01.顧客ID WHERE " _
        & Mid(sS, Len(sAndOr) + 1) & ")"
  End If
  Call SetFilter(sS)
End Sub

Private Sub btn2_Click()
  Me.op1 = 0
  Me.cbx1 = Null
  Me.txt1 = Null
  Me.txt2 = Null
  Call SetFilter("")
End Sub

Private Sub SetFilterOne()
  Dim sS As String

  sS = ""
  If (Me.NewRecord) Then
    sS = "売上ID = 0"
  ElseIf (Not IsNull(Me.売上ID)) Then
    sS = "売上ID = " & Me.売上ID
  End If
  Call SetFilter(sS)
End Sub

Private Sub op1_Click()
  Select Case Me.op1
    Case 0
        Call btn1_Click
    Case Else
        Call SetFilterOne
  End Select
End Sub

Private Sub Form_Current()
  If (Me.op1 > 0) Then Call SetFilterOne
End Sub

Private Sub Form_BeforeUpdate(Cancel As Integer)
  If (IsNull(Me.顧客ID)) Then Cancel = True
  If (IsNull(Me.日付)) Then Cancel = True
  If (Cancel) Then
    MsgBox "チャンと入力して"
  ElseIf (Me.NewRecord) Then
    Me.売上ID = Nz(DMax("売上ID", "T02"), 0) + 1
  End If
End Sub

Private Sub cbx1_NotInList(NewData As String, Response As Integer)
  Dim sSql As String

  Response = acDataErrContinue
  If (MsgBox(NewData & " を追加しますか?", vbQuestion + vbYesNo, "会社追加") = vbYes) Then
    sSql = "INSERT INTO T01(顧客ID,会社名) VALUES (" _
        & Nz(DMax("顧客ID", "T01"), 0) + 1 & ",'" & NewData & "');"
    CurrentDb.Execute sSql
    Response = acDataErrAdded

    If (Me.ActiveControl Is Me.cbx1) Then
      Me.顧客ID.Requery
    Else
      Me.cbx1.Requery
    End If
  End If
End Sub

Private Sub 顧客ID_NotInList(NewData As String, Response As Integer)
  Call cbx1_NotInList(NewData, Response)
End Sub

新規レコードで「個別」状態だったら、サブフォーム表示を新規だけにしたいので
データの無い 売上ID = 0 で Filter を設定しています。
コンボボックスの「リスト外入力」で登録したら、フォーム上にある他のコンボボックスを
Requery していました。
これ、フォーカスを得た時に Requery する方法もあると思います。

これで完成です。


実際に作る時には、テーブル「T02」「T03」をもう少し見直しますか・・・
「T03」に、1つの「売上ID」に「細番」で複数登録するようにするとか・・・・


サンプルは以下
 バージョン 20002003 (2002)2007
 ファイル kEnt100_2000.zipkEnt100_2003.zipkEnt100_2007.zip
 サイズ 40,95732,06846,039
※ ファイルは zip 形式
※ 2007 以外は、2007 保存時に変換 & 各バージョンで動作確認 & 最適化

関連記事

2011/10/10

Category: サンプルかな

TB: 0  /  CM: 0

top △

この記事に対するコメント

top △

コメントの投稿

Secret

top △

トラックバック

トラックバックURL
→http://kikutips.blog13.fc2.com/tb.php/100-26d0d58b
この記事にトラックバックする(FC2ブログユーザー)

top △


上記広告は1ヶ月以上更新のないブログに表示されています。新しい記事を書くことで広告を消せます。