Access文物古籍组合框多选查询02版

时　间:2016-09-07 11:12:43
作　者:张义成   ID：37928  城市：赤峰
摘　要:Access文物古籍组合框多选查询02版
正　文:

Option Compare Database
Option Explicit
Dim strV As String

'编者 张义成
'日期 2016-09-08
'------------------------------
'txtYesNo 是否锁定 是
'txtAndOr 是否锁定 是
'cbo项目 限于列表 是
'cbo单选 限于列表 否
'cbo多选 限于列表 是
'cbo名称 限于列表 否
'cbo编号 限于列表 否
'cbo序号 限于列表 否
'txt多选 是否锁定 是
'cbo首序 限于列表 是
'------------------------------

Private Sub txtYesNo_Click()
On Error GoTo ErrorHandler
    If txtYesNo = "禁止重复" Then
        txtYesNo = "允许重复"
        txtYesNo.ForeColor = 8453888                     '绿色
    Else
        txtYesNo = "禁止重复"
        txtYesNo.ForeColor = 8454143                     '黄色
    End If
        txt空无.SetFocus
ErrorHandlerExit:
    Exit Sub
ErrorHandler:
    MsgBox "Error No：" & Err.Number & "    Description：" & Err.Description
    Resume ErrorHandlerExit
End Sub

Private Sub txtAndOr_Click()
On Error GoTo ErrorHandler
    If txtAndOr = "Or" Then
        txtAndOr = "And"
        txtAndOr.ForeColor = 8453888                     '绿色
    Else
        txtAndOr = "Or"
        txtAndOr.ForeColor = 8454143                     '黄色
    End If
        txt空无.SetFocus
ErrorHandlerExit:
    Exit Sub
ErrorHandler:
    MsgBox "Error No：" & Err.Number & "    Description：" & Err.Description
    Resume ErrorHandlerExit
End Sub

Private Sub cbo项目_AfterUpdate()
On Error GoTo ErrorHandler
        cbo单选.RowSource = "SELECT DISTINCT " & cbo项目 & " FROM tbl藏品 ORDER BY " & cbo项目 & " DESC"
        cbo单选.Requery
        cbo多选.RowSource = "SELECT DISTINCT " & cbo项目 & " FROM tbl藏品 ORDER BY " & cbo项目
        cbo多选.Requery
        cbo单选.SetFocus
ErrorHandlerExit:
    Exit Sub
ErrorHandler:
    MsgBox "Error No：" & Err.Number & "    Description：" & Err.Description
    Resume ErrorHandlerExit
End Sub

Private Sub cbo项目_GotFocus()
On Error GoTo ErrorHandler
        cbo项目.Dropdown
ErrorHandlerExit:
    Exit Sub
ErrorHandler:
    MsgBox "Error No：" & Err.Number & "    Description：" & Err.Description
    Resume ErrorHandlerExit
End Sub

Private Sub cbo单选_AfterUpdate()
On Error GoTo ErrorHandler
    If IsNull(cbo单选) Or cbo单选 = "" Then
        txt空无.SetFocus
        Exit Sub
    Else
        If IsNull(cbo项目) Or cbo项目 = "" Then
            MsgBox "请为 cbo项目 赋值 啊哦 ！", vbInformation, "温馨提示"
            cbo项目.SetFocus
            Exit Sub
        Else
                cbo多选 = cbo单选
            If txtYesNo = "禁止重复" Then
                If strV Like "*" & cbo多选 & "*" Then
                    'If strV Like "*" & cbo多选 & "*" = True Then 的默认形式
                    '从 字符串 中模糊查找 子字符串 的一种简缩结构
                        Dim strM As String, strN As String, intX As Integer
                            strM = "cbo多选，同时赋值，" & Chr(13) & Chr(10)
                            strM = strM & "模糊查找，数据已有。" & Chr(13) & Chr(10)
                            strM = strM & "是否允许？（默认 是）"
                            strN = "温馨提示"
                            intX = MsgBox(strM, vbInformation + vbYesNo, strN)
                    If intX = vbYes Then         'vbYes = 6  vbNo = 7
                        txtYesNo = "允许重复"
                        strV = strV & " " & txtAndOr & " " & cbo项目 & " Like '*" & cbo多选 & "*'"
                        txtYesNo = "禁止重复"
                    End If
                Else
                    strV = strV & " " & txtAndOr & " " & cbo项目 & " Like '*" & cbo多选 & "*'"
                End If
            Else
                strV = strV & " " & txtAndOr & " " & cbo项目 & " Like '*" & cbo多选 & "*'"
            End If
        End If
            Dim strW As String
                strW = Trim(strV)                'Trim() 删除字符串首尾空格
        If Mid(strW, 1, 3) = "And" Then
            strW = Mid(strW, 5)
        ElseIf Mid(strW, 1, 2) = "Or" Then
            strW = Mid(strW, 4)
        End If
            cbo多选 = strW
            strV = strW
            txt空无.SetFocus
    End If
ErrorHandlerExit:
    Exit Sub
ErrorHandler:
    MsgBox "Error No：" & Err.Number & "    Description：" & Err.Description
    Resume ErrorHandlerExit
End Sub

Private Sub cbo单选_GotFocus()
On Error GoTo ErrorHandler
        cbo单选.Dropdown
ErrorHandlerExit:
    Exit Sub
ErrorHandler:
    MsgBox "Error No：" & Err.Number & "    Description：" & Err.Description
    Resume ErrorHandlerExit
End Sub

Private Sub opt单选_Click()
On Error GoTo ErrorHandler
    If IsNull(cbo单选) Or cbo单选 = "" Then
        opt单选Lab.Caption = "opt单选_模糊/精确 &A"
        opt单选Lab.ForeColor = 16777215                  '白色
        txt空无.SetFocus
        Exit Sub
    Else
        If IsNull(cbo项目) Or cbo项目 = "" Then
            MsgBox "请为 cbo项目 赋值 啊哦 ！", vbInformation, "温馨提示"
            cbo项目.SetFocus
            Exit Sub
        Else
                txt空无.SetFocus
            If opt单选 = True Then
                If cbo项目 = "编号" Then DoCmd.OpenQuery "qry藏品_单选_模糊_编号"
                If cbo项目 = "名称" Then DoCmd.OpenQuery "qry藏品_单选_模糊_名称"
                If cbo项目 = "年代" Then DoCmd.OpenQuery "qry藏品_单选_模糊_年代"
                If cbo项目 = "级码" Then DoCmd.OpenQuery "qry藏品_单选_模糊_级码"
                If cbo项目 = "品类" Then DoCmd.OpenQuery "qry藏品_单选_模糊_品类"
                If cbo项目 = "质类" Then DoCmd.OpenQuery "qry藏品_单选_模糊_质类"
                If cbo项目 = "质型" Then DoCmd.OpenQuery "qry藏品_单选_模糊_质型"
                If cbo项目 = "质地" Then DoCmd.OpenQuery "qry藏品_单选_模糊_质地"
                If cbo项目 = "完残" Then DoCmd.OpenQuery "qry藏品_单选_模糊_完残"
                opt单选Lab.Caption = "当前_opt单选_模糊 &A"
                opt单选Lab.ForeColor = 8453888                   '绿色
            Else
                If cbo项目 = "编号" Then DoCmd.OpenQuery "qry藏品_单选_精确_编号"
                If cbo项目 = "名称" Then DoCmd.OpenQuery "qry藏品_单选_精确_名称"
                If cbo项目 = "年代" Then DoCmd.OpenQuery "qry藏品_单选_精确_年代"
                If cbo项目 = "级码" Then DoCmd.OpenQuery "qry藏品_单选_精确_级码"
                If cbo项目 = "品类" Then DoCmd.OpenQuery "qry藏品_单选_精确_品类"
                If cbo项目 = "质类" Then DoCmd.OpenQuery "qry藏品_单选_精确_质类"
                If cbo项目 = "质型" Then DoCmd.OpenQuery "qry藏品_单选_精确_质型"
                If cbo项目 = "质地" Then DoCmd.OpenQuery "qry藏品_单选_精确_质地"
                If cbo项目 = "完残" Then DoCmd.OpenQuery "qry藏品_单选_精确_完残"
                opt单选Lab.Caption = "当前_opt单选_精确 &A"
                opt单选Lab.ForeColor = 8454143                   '黄色
            End If
        End If
    End If
ErrorHandlerExit:
    Exit Sub
ErrorHandler:
    MsgBox "Error No：" & Err.Number & "    Description：" & Err.Description
        If Err.Number = 2001 Then
            Dim strA As String
            strA = "如果 错误提示 2001 您取消了前次的操作，" & Chr(13) & Chr(10)
            strA = strA & "那么 很有可能是 数据类型 不匹配 造成的。" & Chr(13) & Chr(10)
            strA = strA & "例如 cbo项目 为 数字类型，而 cbo单选 却输入了文字，" & Chr(13) & Chr(10)
            strA = strA & "并且 查询网格中的条件“[forms]![frm藏品]![cbo单选]”" & Chr(13) & Chr(10)
            strA = strA & "前面 未加“Like ”，" & Chr(13) & Chr(10)
            strA = strA & "结果 就会出现这种情况。"
            MsgBox strA, vbInformation, "温馨提示"
        End If
    Resume ErrorHandlerExit
End Sub

Private Sub cbo多选_AfterUpdate()
On Error GoTo ErrorHandler
    If IsNull(cbo多选) Or cbo多选 = "" Then
        txt空无.SetFocus
        Exit Sub
    Else
        If IsNull(cbo项目) Or cbo项目 = "" Then
            MsgBox "请为 cbo项目 赋值 啊哦 ！", vbInformation, "温馨提示"
            cbo项目.SetFocus
            Exit Sub
        Else
                cbo单选 = cbo多选
            If txtYesNo = "禁止重复" Then
                If Not strV Like "*" & cbo多选 & "*" Then
                    'If strV Like "*" & cbo多选 & "*" = False Then 的等价形式
                    strV = strV & " " & txtAndOr & " " & cbo项目 & " Like '*" & cbo多选 & "*'"
                End If
            Else
                    strV = strV & " " & txtAndOr & " " & cbo项目 & " Like '*" & cbo多选 & "*'"
            End If
        End If
            Dim strW As String
                strW = Trim(strV)                'Trim() 删除字符串首尾空格
        If Mid(strW, 1, 3) = "And" Then
            strW = Mid(strW, 5)
        ElseIf Mid(strW, 1, 2) = "Or" Then
            strW = Mid(strW, 4)
        End If
            cbo多选 = strW
            strV = strW
            txt空无.SetFocus
    End If
ErrorHandlerExit:
    Exit Sub
ErrorHandler:
    MsgBox "Error No：" & Err.Number & "    Description：" & Err.Description
    Resume ErrorHandlerExit
End Sub

Private Sub cbo多选_GotFocus()
On Error GoTo ErrorHandler
        cbo多选.Dropdown
ErrorHandlerExit:
    Exit Sub
ErrorHandler:
    MsgBox "Error No：" & Err.Number & "    Description：" & Err.Description
    Resume ErrorHandlerExit
End Sub

Private Sub opt多选_Click()
On Error GoTo ErrorHandler
    If IsNull(cbo多选) Or cbo多选 = "" Then
            '由于声明字符串变量 strV 的默认值等于 "" ，
            '所以 If 语句中的 And strV <> "" 是否设置，
            '直接关系到 Else 以及 opt多选Lab 的取舍。
        If Not IsNull(strV) And strV <> "" Then
            cbo多选 = strV
            Call fun多选
        Else
            opt多选Lab.Caption = "opt多选_模糊/精确 &S"
            opt多选Lab.ForeColor = 16777215                  '白色
        End If
    Else
        Call fun多选
    End If
        txt空无.SetFocus
ErrorHandlerExit:
    Exit Sub
ErrorHandler:
    MsgBox "Error No：" & Err.Number & "    Description：" & Err.Description
    Resume ErrorHandlerExit
End Sub

Private Function fun多选()
                Dim strW As String
                    strW = strV
            If opt多选 = False Then
                strW = Replace(strV, "*", "")            'Replace(strV, "*", "") 字符串替换 去除 *
            End If
                txt多选 = strW
            If chd藏品子窗体.Form.RecordSource <> "SELECT * FROM tbl藏品 ORDER BY 名称, 编号" Then
                chd藏品子窗体.Form.RecordSource = "SELECT * FROM tbl藏品 ORDER BY 名称, 编号"
            End If
                chd藏品子窗体.Form.Filter = strW
                chd藏品子窗体.Form.FilterOn = True
            If opt多选 = True Then
                opt多选Lab.Caption = "当前_opt多选_模糊 &S"
                opt多选Lab.ForeColor = 8453888                   '绿色
            Else
                opt多选Lab.Caption = "当前_opt多选_精确 &S"
                opt多选Lab.ForeColor = 8454143                   '黄色
            End If
End Function

Private Sub cbo名称_AfterUpdate()
On Error GoTo ErrorHandler
        Dim strSQL As String
            strSQL = "SELECT * FROM tbl藏品 " & _
                    "WHERE 名称 Like '*' & [forms]![frm藏品]![cbo名称] & '*' " & _
                    "ORDER BY 名称, 编号"
        cbo编号 = cbo名称.Column(1)
        cbo序号 = cbo名称.Column(2)
        chd藏品子窗体.Form.RecordSource = strSQL
        txt空无.SetFocus
ErrorHandlerExit:
    Exit Sub
ErrorHandler:
    MsgBox "Error No：" & Err.Number & "    Description：" & Err.Description
    Resume ErrorHandlerExit
End Sub

Private Sub cbo名称_GotFocus()
On Error GoTo ErrorHandler
        cbo名称.Dropdown
ErrorHandlerExit:
    Exit Sub
ErrorHandler:
    MsgBox "Error No：" & Err.Number & "    Description：" & Err.Description
    Resume ErrorHandlerExit
End Sub

Private Sub cbo编号_AfterUpdate()
On Error GoTo ErrorHandler
        Dim strSQL As String
            strSQL = "SELECT * FROM tbl藏品 " & _
                    "WHERE 编号 Like '*' & [forms]![frm藏品]![cbo编号] & '*' " & _
                    "ORDER BY 编号"
        cbo序号 = cbo编号.Column(1)
        cbo名称 = cbo编号.Column(2)
        chd藏品子窗体.Form.RecordSource = strSQL
        txt空无.SetFocus
ErrorHandlerExit:
    Exit Sub
ErrorHandler:
    MsgBox "Error No：" & Err.Number & "    Description：" & Err.Description
    Resume ErrorHandlerExit
End Sub

Private Sub cbo编号_GotFocus()
On Error GoTo ErrorHandler
        cbo编号.Dropdown
ErrorHandlerExit:
    Exit Sub
ErrorHandler:
    MsgBox "Error No：" & Err.Number & "    Description：" & Err.Description
    Resume ErrorHandlerExit
End Sub

Private Sub cbo序号_AfterUpdate()
On Error GoTo ErrorHandler
        Dim strSQL As String
            strSQL = "SELECT * FROM tbl藏品 " & _
                    "WHERE 序号 Like [forms]![frm藏品]![cbo序号] " & _
                    "ORDER BY 序号, 编号"
        cbo编号 = cbo序号.Column(1)
        cbo名称 = cbo序号.Column(2)
        chd藏品子窗体.Form.RecordSource = strSQL
        txt空无.SetFocus
ErrorHandlerExit:
    Exit Sub
ErrorHandler:
    MsgBox "Error No：" & Err.Number & "    Description：" & Err.Description
    Resume ErrorHandlerExit
End Sub

Private Sub cbo序号_GotFocus()
On Error GoTo ErrorHandler
        cbo序号.Dropdown
ErrorHandlerExit:
    Exit Sub
ErrorHandler:
    MsgBox "Error No：" & Err.Number & "    Description：" & Err.Description
    Resume ErrorHandlerExit
End Sub

Private Sub cmd重置_Click()
On Error GoTo ErrorHandler
        strV = Empty
        txtYesNo = Empty
        txtYesNo.ForeColor = 8454143                     '黄色
        txtAndOr = Empty
        txtAndOr.ForeColor = 8454143                     '黄色
        cbo项目 = "名称"
        cbo单选 = Empty
        cbo单选.RowSource = "SELECT DISTINCT 名称 FROM tbl藏品 ORDER BY 名称 DESC"
        cbo单选.Requery
        opt单选 = Empty
        opt单选Lab.Caption = "opt单选_模糊/精确 &A"
        opt单选Lab.ForeColor = 16777215                  '白色
        cbo多选 = Empty
        cbo多选.RowSource = "SELECT DISTINCT 名称 FROM tbl藏品 ORDER BY 名称"
        cbo多选.Requery
        opt多选 = Empty
        opt多选Lab.Caption = "opt多选_模糊/精确 &S"
        opt多选Lab.ForeColor = 16777215                  '白色
        cbo名称 = "名称"
        cbo编号 = "编号"
        cbo序号 = Empty
        txt多选 = Empty
        cbo首序 = "名称"
        chd藏品子窗体.Form.RecordSource = "SELECT * FROM tbl藏品 ORDER BY 名称, 编号"
        chd藏品子窗体.Form.Filter = ""
        chd藏品子窗体.Form.FilterOn = False
        txt空无.SetFocus
ErrorHandlerExit:
    Exit Sub
ErrorHandler:
    MsgBox "Error No：" & Err.Number & "    Description：" & Err.Description
    Resume ErrorHandlerExit
End Sub

Private Sub cmd多选_Click()
On Error GoTo ErrorHandler
    If IsNull(txt多选) Or txt多选 = "" Then
        txt空白.SetFocus
        Exit Sub
    Else
        If IsNull(cbo首序) Or cbo首序 = "" Then
            MsgBox "请为 cbo首序 赋值 啊哦 ！", vbInformation, "温馨提示"
            cbo首序.SetFocus
            Exit Sub
        Else
            txt空白.SetFocus
            Call fun创建多选
            DoCmd.OpenQuery "qry藏品_多选"
        End If
    End If
ErrorHandlerExit:
    Exit Sub
ErrorHandler:
    If Err.Number = 3012 Then                               '3012 对象'查询名称'已存在
        DoCmd.DeleteObject acQuery, "qry藏品_多选"
        Call fun创建多选
        DoCmd.OpenQuery "qry藏品_多选"
    ElseIf Err.Number = 7874 Then                           '7874 不能找到对象"查询名称"
        Call fun创建多选
        DoCmd.OpenQuery "qry藏品_多选"
    Else
        MsgBox "Error No：" & Err.Number & "    Description：" & Err.Description
    End If
    Resume ErrorHandlerExit
End Sub

Private Function fun创建多选()
        Dim dbs As Database, qdf As QueryDef, strSQL As String
        Set dbs = CurrentDb
        strSQL = "SELECT tbl藏品.* FROM tbl藏品 WHERE " & txt多选 & " ORDER BY " & cbo首序 & ", 编号"
        Set qdf = dbs.CreateQueryDef("qry藏品_多选", strSQL)
End Function

Private Sub cbo首序_AfterUpdate()
On Error GoTo ErrorHandler
        txt空白.SetFocus
ErrorHandlerExit:
    Exit Sub
ErrorHandler:
    MsgBox "Error No：" & Err.Number & "    Description：" & Err.Description
    Resume ErrorHandlerExit
End Sub

Private Sub cbo首序_GotFocus()
On Error GoTo ErrorHandler
        cbo首序.Dropdown
ErrorHandlerExit:
    Exit Sub
ErrorHandler:
    MsgBox "Error No：" & Err.Number & "    Description：" & Err.Description
    Resume ErrorHandlerExit
End Sub

Private Sub cmd藏品表_Click()
On Error GoTo ErrorHandler
        txt空位.SetFocus
        DoCmd.OpenTable "tbl藏品"
ErrorHandlerExit:
    Exit Sub
ErrorHandler:
    MsgBox "Error No：" & Err.Number & "    Description：" & Err.Description
    Resume ErrorHandlerExit
End Sub

Private Sub cmd藏品查询_Click()
On Error GoTo ErrorHandler
        txt空位.SetFocus
        DoCmd.OpenQuery "qry藏品"
ErrorHandlerExit:
    Exit Sub
ErrorHandler:
    MsgBox "Error No：" & Err.Number & "    Description：" & Err.Description
    Resume ErrorHandlerExit
End Sub

Private Sub cmd重启_Click()
On Error GoTo ErrorHandler
        Call cmd重置_Click
        DoCmd.Close
        DoCmd.OpenForm "frm藏品"
ErrorHandlerExit:
    Exit Sub
ErrorHandler:
    MsgBox "Error No：" & Err.Number & "    Description：" & Err.Description
    Resume ErrorHandlerExit
End Sub

Private Sub cmd关闭_Click()
On Error GoTo ErrorHandler
        Call cmd重置_Click
        DoCmd.Close
ErrorHandlerExit:
    Exit Sub
ErrorHandler:
    MsgBox "Error No：" & Err.Number & "    Description：" & Err.Description
    Resume ErrorHandlerExit
End Sub

附   件:

图   示: