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

时　间:2016-08-31 09:14:50
作　者:张义成   ID：37928  城市：赤峰
摘　要:Access文物古籍组合框多选查询01版
正　文:

Option Compare Database
Option Explicit
        Dim strV As String

Private Sub cmd重置_Click()
On Error GoTo ErrorHandler

        strV = Empty
       
        txtYesNo = Empty
        txtYesNo.ForeColor = 8454143                     '黄色
       
        txtAndOr = Empty
        txtAndOr.ForeColor = 8454143                     '黄色
       
        cbo项目 = Empty
       
        cbo单选.RowSource = "SELECT DISTINCT 名称 FROM tbl藏品 ORDER BY 名称;"
        cbo单选.Requery
        cbo单选 = Empty
       
        opt单选 = Empty
        opt单选Lab.ForeColor = 16777215                  '白色
        opt单选Lab.Caption = "opt单选_模糊/精确 &A"
       
        cbo多选.RowSource = "SELECT DISTINCT 名称 FROM tbl藏品 ORDER BY 名称;"
        cbo多选.Requery
        cbo多选 = Empty
       
        opt多选 = Empty
        opt多选Lab.ForeColor = 16777215                  '白色
        opt多选Lab.Caption = "opt多选_模糊/精确 &S"
       
        txt多选 = Empty
        cbo首序 = Empty
       
        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 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单选.RowSource = "SELECT DISTINCT " & cbo项目 & " FROM tbl藏品 ORDER BY " & cbo项目
        'cbo单选.RowSource = "SELECT DISTINCT " & cbo项目 & " FROM tbl藏品"
       
        'cbo多选.RowSource = "SELECT DISTINCT " & cbo项目 & " FROM tbl藏品 ORDER BY " & cbo项目 & " DESC"
        'cbo多选.RowSource = "SELECT DISTINCT " & cbo项目 & " FROM tbl藏品 ORDER BY " & cbo项目
        'cbo多选.RowSource = "SELECT DISTINCT " & cbo项目 & " FROM tbl藏品"
       
        cbo单选.RowSource = "SELECT DISTINCT " & cbo项目 & " FROM tbl藏品"
        cbo单选.Requery
        cbo单选 = Empty
       
        opt单选 = Empty
        opt单选Lab.ForeColor = 16777215                  '白色
        opt单选Lab.Caption = "opt单选_模糊/精确 &A"
       
        cbo多选.RowSource = "SELECT DISTINCT " & cbo项目 & " FROM tbl藏品"
        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()

    If IsNull(cbo项目) Or cbo项目 = "" Then
        MsgBox "请为 cbo项目 组合框 赋值 啊哦 ！", vbExclamation, "郑重提示"
        cbo项目.SetFocus
    Else
        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
        MsgBox "请为 cbo项目 组合框 赋值 啊哦 ！", vbExclamation, "郑重提示"
        opt单选 = False
        cbo项目.SetFocus
        Exit Sub
       
    ElseIf (Not IsNull(cbo项目) And cbo项目 <> "") And (IsNull(cbo单选) Or cbo单选 = "") Then
        MsgBox "请为 cbo单选 组合框 赋值 啊哦 ！", vbExclamation, "郑重提示"
        opt单选 = False
        cbo单选.SetFocus
        Exit Sub
       
    ElseIf (Not IsNull(cbo项目) And cbo项目 <> "") And (Not IsNull(cbo单选) And cbo单选 <> "") Then
   
        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藏品_单选_模糊_件套"
            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藏品_单选_精确_件套"
            If cbo项目 = "完残" Then DoCmd.OpenQuery "qry藏品_单选_精确_完残"
           
            opt单选Lab.Caption = "当前_opt单选_精确 &A"
            opt单选Lab.ForeColor = 8454143                   '黄色
           
        End If
       
            txt空位.SetFocus
    Else
        MsgBox "opt单选_Click() 条件语句 Else 发出警告 ！", vbExclamation, "郑重提示"
        txt空位.SetFocus
        Exit Sub
    End If
   
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
        MsgBox "请为 cbo项目 组合框 赋值 啊哦 ！", vbExclamation, "郑重提示"
        cbo项目.SetFocus
        Exit Sub
       
    ElseIf (Not IsNull(cbo项目) And cbo项目 <> "") And (IsNull(cbo多选) Or cbo多选 = "") Then
        MsgBox "请为 cbo多选 组合框 赋值 啊哦 ！", vbExclamation, "郑重提示"
        cbo多选.SetFocus
        Exit Sub
       
    ElseIf (Not IsNull(cbo项目) And cbo项目 <> "") And (Not IsNull(cbo多选) And cbo多选 <> "") Then
   
            cbo单选 = cbo多选
           
        If txtYesNo = "禁止重复" Then
            If strV Like "*" & cbo多选 & "*" = False Then
                strV = strV & " " & txtAndOr & " " & cbo项目 & " Like '*" & cbo多选 & "*'"
            End If
        Else
                strV = strV & " " & txtAndOr & " " & cbo项目 & " Like '*" & cbo多选 & "*'"
        End If
                cbo多选 = strV
    Else
        MsgBox "cbo多选_AfterUpdate() 条件语句 Else 发出警告 ！", vbExclamation, "郑重提示"
        txt空无.SetFocus
        Exit Sub
    End If
   
        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 opt多选_Click()
On Error GoTo ErrorHandler

    If IsNull(cbo项目) Or cbo项目 = "" Then
        MsgBox "请为 cbo项目 组合框 赋值 啊哦 ！", vbExclamation, "郑重提示"
        opt多选 = False
        cbo项目.SetFocus
        Exit Sub
       
    ElseIf (Not IsNull(cbo项目) And cbo项目 <> "") And (IsNull(cbo多选) Or cbo多选 = "") Then
        MsgBox "请为 cbo多选 组合框 赋值 啊哦 ！", vbExclamation, "郑重提示"
        opt多选 = False
        cbo多选.SetFocus
        Exit Sub
       
    ElseIf (Not IsNull(cbo项目) And cbo项目 <> "") And (Not IsNull(cbo多选) And cbo多选 <> "") Then
   
            Dim strW As String
                strW = Trim(strV)
               
        If Mid(strW, 1, 3) = "And" Then
            strW = Mid(strW, 5)
           
        ElseIf Mid(strW, 1, 2) = "Or" Then
            strW = Mid(strW, 4)
           
        Else
            MsgBox "opt多选_Click() 条件语句 Else 发出警告 ！", vbExclamation, "郑重提示"
            txt空无.SetFocus
            Exit Sub
        End If
       
        If opt多选 = False Then
            strW = Replace(strW, "*", "")
        End If
       
            txt多选 = strW
           
            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
    Else
        MsgBox "opt多选_Click() 条件语句 Else 发出警告 ！", vbExclamation, "郑重提示"
        txt空无.SetFocus
        Exit Sub
    End If
   
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 (Not IsNull(cbo首序) And cbo首序 <> "") And (Not IsNull(txt多选) And txt多选 <> "") Then
        txt空白.SetFocus
        Call fun创建多选
        DoCmd.OpenQuery "qry藏品_多选"
       
    Else
        MsgBox "txt多选/cbo首序 不能为空！ 单击 opt多选/cbo首序 添加数据。", vbExclamation, "郑重提示"
        txt空白.SetFocus
        Exit Sub
       
    End If
   
ErrorHandlerExit:
    Exit Sub
ErrorHandler:

        'MsgBox "Error No：" & Err.Number & "    Description：" & Err.Description
       
    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 "cmd多选_Click() ErrorHandler 条件语句 Else 发出警告 ！", vbExclamation, "郑重提示"
    End If
   
        txt空白.SetFocus
       
    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
        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
        DoCmd.Close
ErrorHandlerExit:
    Exit Sub
ErrorHandler:
    MsgBox "Error No：" & Err.Number & "    Description：" & Err.Description
    Resume ErrorHandlerExit
End Sub

附   件:

图   示: