GDIplusCODE


☆実行元の帳票フォーム（表）フォームモジュール
'オールドファッションフィルターをクラス化
Dim oldFilterCls As oldFashionFilterCls

'初期化ルーチンで親クラス設定
'親クラスに、実行元のフォームを渡す
Private Sub Form_Load()
  Set oldFilterCls = New oldFashionFilterCls
  Set oldFilterCls.Form = Me
End Sub

'フィルタをかける
Private Sub filterButton_Click()
   oldFilterCls.filterOn
End Sub

'Fileterボタン横の解除ボタン
Private Sub resetFilterButton_Click()
  oldFilterCls.filterOff
End Sub

☆親クラス　oldFashionFilterCls
'===============================================================
'　Old fashioned Filter Class
'  旧称帳票フォーム（2010では表フォーム）のフッターセクション等に
'　CommandButtonを二個　（フィルター設定、解除）置いて
'  Access2000の頃のフィルター動作＋重ね掛け機能を実現
'  2013/1/24,　2013/1/28修正
'===============================================================

Dim myForm As Object

'複数条件でのフィルター様にモジュールレベルで保持
Dim filterString  As String
'詳細セクションのテキストボックスを引き継ぐクラスモジュールのメモリを確保
Dim myControls() As exControlClass
'選択列 最初非可視ラベルでやっていたが載せ替え
Dim selectedColumn As String
'フォームがセットされているかのフラグ
Dim myFlagFormSet As Boolean

Public Property Get flagFormSet() As Boolean
  flagFormSet = myFlagFormSet
End Property

Public Property Set Form(newForm As Object)
  Dim myControl As Control

  Set myForm = newForm
  myFlagFormSet = True
  ReDim myControls(0 To 0)
  For Each myControl In myForm.Section(0).Controls
    If TypeName(myControl) = "TextBox" Then
      ReDim Preserve myControls(0 To UBound(myControls) + 1)
      Set myControls(UBound(myControls)) = New exControlClass
       myControls(UBound(myControls)).setTextBox myControl, UBound(myControls)
       Set myControls(UBound(myControls)).parent = Me
    End If
  Next myControl
End Property

'クラスモジュールから起動して、indexを保持（文字列形式）
Sub controlslClicked(myObj As exControlClass)
  selectedColumn = CStr(myObj.index)
End Sub

'フィルタをかける
Public Sub filterOn()
  Dim tempfilterString  As String
  Dim fieldName As String, fieldValue As Variant
    
  If myForm Is Nothing Then
    MsgBox "フォームがセットされていません"
    Exit Sub
  End If
  '2013/1/28 テキストボックス以外の要素のある詳細セクションでの不具合対策で子クラスからの取得に変更
  fieldValue = myControls(selectedColumn).value
  fieldName = myControls(selectedColumn).name

  Select Case TypeName(fieldValue)
    Case "String"
      tempfilterString = fieldName & "='" & fieldValue & "'"
    Case "Date"
      tempfilterString = fieldName & "=#" & fieldValue & "#"
    Case Else
      tempfilterString = fieldName & "=" & fieldValue
  End Select
  If filterString = "" Then
    filterString = tempfilterString
  Else
    filterString = filterString & " AND " & tempfilterString
  End If
  myForm.filter = filterString
  myForm.filterOn = True
End Sub

'Filter解除
Public Sub filterOff()
  If myForm Is Nothing Then
    MsgBox "フォームがセットされていません"
    Exit Sub
  End If
  myForm.filterOn = False
  filterString = ""
End Sub

☆子クラス　exControlClass
Private WithEvents myTextBox As TextBox
Private myIndex As Long
Private myParent As Object

Public Sub setTextBox(newTextBox As TextBox, newIndex As Long)
    Set myTextBox = newTextBox
    'これがミソで、これを入れないとClickイベントがクラスに引き継がれない
    myTextBox.OnClick = "[Event Procedure]"
    myIndex = newIndex
End Sub

'TabIndexを用いる手もあるが、取りあえず取得順を保持している
Public Property Get index() As Long
  index = myIndex
End Property

Private Sub myTextBox_Click()
    Call myParent.controlslClicked(Me)
End Sub

Public Property Set parent(newParent As Object)
    Set myParent = newParent
End Property

'2013/1/28 テキストボックス以外の要素のある詳細セクションでの不具合対策で追加
Public Property Get name() as String
	name = myTextBox.name
End Property

Public Property Get value() as String
	value = myTextBox.value
End Property
Old fashioned filter of Access form
