Access Knowhow Forms - Intermediate 020

フォーム上のレコードを並べ替えたり絞り込むための関数

連続フォームのレコードを昇順/降順に並べ替えたり、任意のフィールドでフィルタ条件を設定してレコードを絞込みするための関数を紹介します。ここで紹介する関数は汎用性がありますから、コマンドボタンのクリックイベントから、=SortbyField_FS()、=Filter_FS()、=ReSet_FS()のようにコールするだけでこれらの処理を実現することができます。

Access 2000を起動して Northwind.mdb を開きます。
データベースウィンドウからフォームタブをクリックして、新規作成ボタンをクリックします。

フォームウィザードを使用して図１に示すようなフォームを作成します。

図１-商品テーブルの一覧を表示するめのフォーム作成

フォームのヘッダー部には、４個のコマンドボタンと４個のテキストボックスを作成します。コマンドボタンは、各フィールドを昇順／降順に並べ替えするとき使用します。黄色のテキストボックスには、フィルタ条件を設定します。

コマンドボタンとテキストボックスのプロパティは、以下のように設定します。

オブジェクト	プロパティ	設定値
コマンドボタン１	クリック時のイベント	=SortbyField_FS([Form])
	タグ	商品コード（コントロールソース名）
	標題	商品コード
コマンドボタン２	クリック時のイベント	=SortbyField_FS([Form])
	タグ	商品名（コントロールソース名）
	標題	商品名
コマンドボタン３	クリック時のイベント	=SortbyField_FS([Form])
	タグ	梱包単位（コントロールソース名）
	標題	梱包単位
コマンドボタン４	クリック時のイベント	=SortbyField_FS([Form])
	タグ	単価（コントロールソース名）
	標題	単価
テキストボックス１	名前	txtProdID
	タグ	商品コード（コントロールソース名）
	背景色	8454143
テキストボックス２	名前	txtProdName
	タグ	商品名（コントロールソース名）
	背景色	8454143
テキストボックス３	名前	txtUnit
	タグ	梱包単位（コントロールソース名）
	背景色	8454143
テキストボックス４	名前	txtUnitPrice
	タグ	単価（コントロールソース名）
	背景色	8454143

詳細部には、連結テキストボックスを４個作成します。

フッター部には、２個のコマンドボタンを作成します。これら２個のコマンドボタンのプロパティは以下のように設定します。

オブジェクト	プロパティ	設定値
コマンドボタン１（フィルタ）	クリック時のイベント	=Filter_FS([Form])
コマンドボタン２（フィルタ解除）	クリック時のイベント	=ReSet_FS([Form])

フォームをfrmレコードの並べ替え／絞込みの名称で保存します。

データベースウインドウからモジュールタブをクリックしてから新規作成のボタンをクリックします。モジュールウィンドウが表示されたら、リスト１の関数をコピー＆ペーストします。モジュールをbasMyLibの名称で保存して閉じます。

リスト１-SortbyField_FS()、Filter_FS()、ReSet_FS()関数


Const conUp = "↑"    ' Sort by Decending Order
Const conDown = "↓"  ' Sort by Asceding Order  

' ************************************************
Public Function SortbyField_FS(frm As Form)
  Dim ctl As Control
  Dim ctl2 As Control
  
  Set ctl = Application.Screen.ActiveControl
  For Each ctl2 In frm.Section(acHeader).Controls
    With ctl2
      If .ControlType = acCommandButton Then
        If ctl.Caption <> .Caption Then
          .Caption = Replace(.Caption, conUp, "", 1, 1, vbTextCompare)
          .Caption = Replace(.Caption, conDown, "", 1, 1, vbTextCompare)
        End If
      End If
    End With
  Next ctl2
  
  With ctl
    If InStr(.Caption, conUp) > 0 Then
      .Caption = Replace(.Caption, conUp, conDown, 1, 1, vbTextCompare)
    ElseIf InStr(.Caption, conDown) > 0 Then
      .Caption = Replace(.Caption, conDown, conUp, 1, 1, vbTextCompare)
    Else
      .Caption = .Caption & conUp
    End If
  End With
  
  With frm
    .OrderBy = ctl.Tag & IIf(InStr(ctl.Caption, conUp) > 0, " DESC", "")
    .OrderByOn = True
    .Requery
  End With
End Function

' ******************************************
Public Function ReSet_FS(frm As Form, _
  Optional strFocus As String) As Boolean

  Dim ctl As Control
  
  With frm
    For Each ctl In .Section(acHeader).Controls
      With ctl
        Select Case .ControlType
          Case acTextBox, acComboBox
            .Value = vbNullString
          Case acCommandButton
            .Caption = Replace(.Caption, conUp, "", 1, 1, vbTextCompare)
            .Caption = Replace(.Caption, conDown, "", 1, 1, vbTextCompare)
        End Select
      End With
    Next ctl
    .OrderBy = ""
    .OrderByOn = False
    .Filter = ""
    .FilterOn = False
    .Requery
    If Len(Nz(strFocus)) > 0 Then
       frm(strFocus).SetFocus
    End If
  End With
  
End Function

' *******************************************
Public Function Filter_FS(frm As Form, _
  Optional strFocus As String) As Boolean

  Dim rs As DAO.Recordset
  Dim ctl As Control
  Dim strFilter As String
  
  With frm
    Set rs = .RecordsetClone
    strFilter = ""
    For Each ctl In .Section(acHeader).Controls
      With ctl
        Select Case .ControlType
          Case acTextBox, acComboBox
            If Len(Trim(Nz(.Value))) > 0 Then
              Select Case rs(.Tag).Type
                Case dbText, dbMemo
                  If InStr(.Value, "*") > 0 Then
                    strFilter = strFilter & .Tag & " Like '" & .Value & "' AND "
                  Else
                    strFilter = strFilter & .Tag & "='" & .Value & "' AND "
                  End If
                Case dbInteger, dbLong, dbCurrency, dbDouble, dbSingle
                  strFilter = strFilter & .Tag & "=" & .Value & " AND "
                Case dbDate
                  strFilter = strFilter & .Tag & "=#" & .Value & "# AND "
              End Select  ' Case rs(.Tag).Type
            End If  ' Len(Trim(Nz(.Value))) > 0
        End Select  ' Case .ControlType
      End With
    Next ctl
    rs.Close
    Set rs = Nothing
  
    If Len(strFilter) = 0 Then
      MsgBox "フィルタ条件を入力してください！", vbOKOnly
      If Len(Nz(strFocus)) > 0 Then
        frm(strFocus).SetFocus
      End If
      Exit Function
    End If
    
    strFilter = Left(strFilter, Len(strFilter) - 4)

    .Filter = strFilter
    .FilterOn = True
    .Requery
    If Len(Nz(strFocus)) > 0 Then
      frm(strFocus).SetFocus
    End If
  End With
  
End Function

データベースウィンドウからフォームタブをクリックして項番３で保存したフォームfrmレコードの並べ替え／絞込みを開きます。単価のコマンドボタンをクリックして、レコードが単価の昇順／降順に並べ替えられるか確認します。次に、フィルタ条件として単価２８００円を入力してフィルタボタンをクリックします。フォーム上に、単価２８００円のレコードのみ表示されることを確認します。

図２-単価のコマンドボタンをクリックして単価の降順に並べ替えした例

図３-フィルタ条件として単価２８００円を設定してレコードを絞り込んだ例

フォームを閉じてAccess 2000を終了します｡