ヘッダー部には、４個のコマンドボタンと４個のテキストボックスを配置します。コマンドボタン（商品コード、商品名、梱包単位、単価）をクリックすると、クリックしたフィールドを昇順／降順に並び替えします。黄色のテキストボックスにはフィルタ条件を入力します。
詳細部には、４個の連結テキストボックスと１個の非連結テキストボックスを配置します。右端の非連結テキストボックスのプロパティは、以下のように設定します。このテキストボックスは、条件付書式設定で使用します。
| オブジェクト |
プロパティ |
設定値 |
| テキストボックス |
名前 |
txtRecno |
| コントロールソース |
=GetColor() |
| 可視 |
いいえ |
フッター部には、４個のコマンドボタンを配置します。色設定ボタンをクリックすると行毎に異なる背景色を表示します。背景色のパターンは７種類用意していますので、色設定ボタンをクリックして好みのパターンを選択することができます。フィルタボタンをクリックすると、ヘッダー部の黄色のテキストボックスで入力した条件で絞込みします。フィルタ解除ボタンをクリックすると、絞込みを解除して全レコード表示します。閉じるのボタンをクリックするとフォームを閉じます。
| リスト１-フォームの各種イベント処理用ＶＢＡコード |
Option Compare Database
Option Explicit
Const conUp = "↑" ' Sort by Decending Order
Const conDown = "↓" ' Sort by Asceding Order
Dim mlngBackColor1(7) As Long
Dim mlngBackColor2(7) As Long
Dim mintIndex As Integer
' *************************
Private Sub cmdExit_Click()
DoCmd.Close
End Sub
' ***************************
Private Sub cmdFilter_Click()
Dim strFilter As String
strFilter = ""
With Me
If Len(.txtProdID) > 0 Then
strFilter = "商品コード = " & .txtProdID & " AND "
End If
If Len(.txtProdName) > 0 Then
If InStr(.txtProdName, "*") > 0 Then
strFilter = strFilter & "商品名 Like '" & .txtProdName & "' AND "
Else
strFilter = strFilter & "商品名 = '" & .txtProdName & "' AND "
End If
End If
If Len(.txtUnit) > 0 Then
If InStr(.txtUnit, "*") > 0 Then
strFilter = strFilter & "梱包単位 Like '" & .txtUnit & "' AND "
Else
strFilter = strFilter & "梱包単位 = '" & .txtUnit & "' AND "
End If
End If
If Len(.txtUnitPrice) > 0 Then
strFilter = "単価 = " & .txtUnitPrice & " AND "
End If
If Len(strFilter) = 0 Then
MsgBox "フィルタ条件を入力してください！", vbOKOnly, "フィルタボタン"
.txtProdID.SetFocus
Exit Sub
End If
strFilter = Left(strFilter, Len(strFilter) - 4)
' MsgBox strFilter
.Filter = strFilter
.FilterOn = True
.Requery
.txtProdID.SetFocus
End With
End Sub
' ***************************
Private Sub cmdProdID_Click()
Call SortbyField("商品コード")
End Sub
' *****************************
Private Sub cmdProdName_Click()
Call SortbyField("商品名")
End Sub
' **************************
Private Sub cmdReSet_Click()
Dim ctl As Control
For Each ctl In Me.Section(acHeader).Controls
With ctl
If .ControlType = acTextBox Then
.Value = vbNullString
.Tag = vbNullString
ElseIf .ControlType = acCommandButton Then
.Caption = Replace(.Caption, conUp, "")
.Caption = Replace(.Caption, conDown, "")
End If
End With
Next ctl
With Me
.OrderBy = ""
.OrderByOn = False
.Filter = ""
.FilterOn = False
.Requery
.txtProdID.SetFocus
End With
End Sub
' *****************************
Private Sub cmdSetColor_Click()
Dim ctl As Control
mintIndex = mintIndex + 1
If mintIndex = UBound(mlngBackColor1) Then
mintIndex = 0
End If
For Each ctl In Me.Section(acDetail).Controls
With ctl
Select Case .ControlType
Case acTextBox, acComboBox
.FormatConditions.Delete
.BackColor = mlngBackColor1(mintIndex)
With .FormatConditions.Add( _
Type:=acExpression, _
Expression1:="[txtRecno]")
.BackColor = mlngBackColor2(mintIndex)
End With
End Select
End With
Next ctl
End Sub
' *************************
Private Sub cmdUnit_Click()
Call SortbyField("梱包単位")
End Sub
' ******************************
Private Sub cmdUnitPrice_Click()
Call SortbyField("単価")
End Sub
' *********************
Private Sub Form_Load()
mlngBackColor1(0) = 13619102
mlngBackColor2(0) = 14150655
mlngBackColor1(1) = 15522517
mlngBackColor2(1) = 14807295
mlngBackColor1(2) = 14606014
mlngBackColor2(2) = 14408667
mlngBackColor1(3) = 15592924
mlngBackColor2(3) = 13882281
mlngBackColor1(4) = 15522517
mlngBackColor2(4) = 16777215
mlngBackColor1(5) = 15592924
mlngBackColor2(5) = 16777215
mlngBackColor1(6) = 14408667
mlngBackColor2(6) = 16777215
mintIndex = 3
With Me
.OrderBy = ""
.OrderByOn = False
.Filter = ""
.FilterOn = False
.txtProdID.SetFocus
End With
End Sub
' ************************************
Private Function GetColor() As Boolean
Dim rs As DAO.Recordset
Dim lngRecno As Long
On Error GoTo Err_GetColor
With Me
Set rs = .RecordsetClone
rs.Bookmark = .Bookmark
lngRecno = rs.AbsolutePosition + 1
End With
Exit_GetColor:
GetColor = lngRecno Mod 2
Exit Function
Err_GetColor:
If rs.EOF Or rs.BOF Then
lngRecno = 0
Else
rs.MoveLast
lngRecno = rs.AbsolutePosition + 2
End If
Resume Exit_GetColor
End Function
' *********************************************
Private Sub SortbyField(strFieldName As String)
Dim ctl As Control
Dim ctl2 As Control
Set ctl = Application.Screen.ActiveControl
For Each ctl2 In Me.Section(acHeader).Controls
With ctl2
If .ControlType = acCommandButton Then
If ctl.Caption <> .Caption Then
.Caption = Replace(.Caption, conUp, "")
.Caption = Replace(.Caption, conDown, "")
End If
End If
End With
Next ctl2
With ctl
If InStr(.Caption, conUp) > 0 Then
.Caption = Replace(.Caption, conUp, conDown)
ElseIf InStr(.Caption, conDown) > 0 Then
.Caption = Replace(.Caption, conDown, conUp)
Else
.Caption = .Caption & conUp
End If
End With
With Me
.OrderBy = strFieldName & IIf(InStr(ctl.Caption, conUp) > 0, " DESC", "")
.OrderByOn = True
.Requery
End With
End Sub
|
をクリックしてフォームモジュールを表示させます。リスト１の各種イベント処理用ＶＢＡコードをコピー＆ペーストします。
をクリックします。色設定のボタンをクリックすると、商品コードの奇数行と偶数行が異なる背景色で表示されます。フィールド名のコマンドボタンをクリックして、レコードを昇順／降順に並び替えして行の背景色が交互に表示されるか確認してください。また、黄色のコンボボックスにフィルタ条件を入力してフィルタボタンをクリックして背景色は交互に表示されるか確認してください。
