query

组合查询 组合查询 组合查询

    Set mrsQueryResult = New ADODB.Recordset
    Set mRequestdb.DBRecordset = mrsQueryResult

    mRequestdb.ExcuteQuery (CreateSql)
    '鼠标指针
    Screen.MousePointer = 0
    
    'msTotalQuery = ""    '查询完毕后将当前查询条件的SQL语句和历史查询条件SQL语句的汇总清空
    Set frmQueryResult.mshfgQueryResult.DataSource = mrsQueryResult
    Set frmQueryResult.rsResult = mrsQueryResult
    frmQueryResult.Caption = Me.Caption & "结果"
    frmQueryResult.Tag = mQueryPrintType
    frmQueryResult.msFieldSource = msFieldSource
    
    
     '将打印字段的列宽与行高取出
    Dim mRecordset As New ADODB.Recordset
    Set mRecordset = New ADODB.Recordset

 
    ReDim sZwmc(0 To frmQueryResult.mshfgQueryResult.Cols - 1)
    ReDim sSql(0 To frmQueryResult.mshfgQueryResult.Cols - 1)
    Set mRequestdb.DBRecordset = mRecordset
    sSqlSel = "select * from zhcx_dycc where cxlx='" & msFieldSource & "'  and czyh='" & strczyh & "'"
    lresult = mRequestdb.ExcuteQuery(sSqlSel)
    If lresult <> 4 Then '判断打印尺寸表里是否为空
        For i = 1 To frmQueryResult.mshfgQueryResult.Cols - 1
            sZwmc(i) = frmQueryResult.mshfgQueryResult.TextMatrix(0, i)
            Set mRequestdb.DBRecordset = mRecordset
            sSql(i) = "select zdkd,zdgd from zhcx_dycc where cxlx='" & msFieldSource & "' and zdmc='" & sZwmc(i) & "' and czyh='" & strczyh & "'"
            lresult = mRequestdb.ExcuteQuery(sSql(i))
            If lresult <> 4 Then
                frmQueryResult.mshfgQueryResult.ColWidth(i) = mRecordset.Fields("zdkd")
            End If
            If i = frmQueryResult.mshfgQueryResult.Cols - 1 Then
                Exit For
            End If
        Next
       
 
    If mrsQueryResult.RecordCount > 0 Then
        For i = 0 To mrsQueryResult.RecordCount
            frmQueryResult.mshfgQueryResult.RowHeight(i) = mRecordset.Fields("zdgd")
            If i = mrsQueryResult.RecordCount Then
                Exit For
            End If
        Next
    End If
End If
    
    Set mRecordset = Nothing
    
    frmQueryResult.Show vbModal
     mrsQueryResult.Close
    Exit Sub

QueryErr:
   ' Set fmtNum = Nothing
     '鼠标指针
    Screen.MousePointer = 0
    MsgBox Err.Description
    
    
End Sub
'处理SQL语句中的单引号
Private Function CheckString(s) As String
    Dim pos As Integer
    pos = InStr(s, "'")
    While pos > 0
        s = Mid(s, 1, pos) & "'" & Mid(s, pos + 1)
        pos = InStr(pos + 2, s, "'")
    Wend
    CheckString = s
    
End Function

Private Sub cmdClearQuery_Click()
    Combolscxtj.ListIndex = -1
    lstQuerySql.Clear
    msTotalTemp = ""  '将当前输入的查询条件清空
    msQuerySql = ""   '将当前输入的查询条件SQL语句清空
    cmdClearQuery.Enabled = False
    'cmdBeginQuery.Enabled = False
    cmbQuery(qiRelation).Enabled = False
    
    Call CheckAddQueryBtnEnabled
    cmbQuery(qiFields).SetFocus
End Sub

Private Sub cmdMove_Click(Index As Integer)
    Dim i As Integer
    
    '移动选中的项（或全部）
    Select Case Index
        Case mdRight:
             Call MoveItems(lstFields, lstSelectedFields)
        Case mdRightAll:
             Call MoveItems(lstFields, lstSelectedFields, True)
        Case mdLeft:
             Call MoveItems(lstSelectedFields, lstFields)
        Case mdLeftAll:
             Call MoveItems(lstSelectedFields, lstFields, True)
    End Select
    
    '判断按钮可用性-左右移动按钮
    If lstFields.ListCount <= 0 Then
        cmdMove(mdRight).Enabled = False
        cmdMove(mdRightAll).Enabled = False
    Else
       cmdMove(mdRightAll).Enabled = True
       cmdMove(mdRight).Enabled = True
    End If
    
    If lstSelectedFields.ListCount <= 0 Then
        cmdMove(mdLeft).Enabled = False
        cmdMove(mdLeftAll).Enabled = False
    Else
        cmdMove(mdLeftAll).Enabled = True
        cmdMove(mdLeft).Enabled = True
    End If
    
    '-上下移动按钮
    Call lstSelectedFields_Click
     
     '- 查询按钮
     If lstSelectedFields.ListCount <= 0 Then
        cmdBeginQuery.Enabled = False
     Else
        cmdBeginQuery.Enabled = True
     End If
     
End Sub

Private Sub cmdQuitQuery_Click()
On Error GoTo QueryErr
    Dim i As Integer
    Dim j As Integer
    Dim sSqlIns() As String
    Dim sSqlDel() As String
    Dim sSqlSel As String
    Dim strxh As String
    Dim strczyh As String
    Dim lresult As Long
    Dim blnExistCzyh As Boolean
    Dim sSqlYj As String
    Dim CeatesqlTemp As String
    Dim strxz As String
    Dim txtCxtj As String
    
    Dim strcxtj As String
    Dim strcxyj As String
    strczyh = "01"
  
    
      
      '鼠标指针
    Screen.MousePointer = 11
  
    If Combolscxtj.Text <> "" Or msTotalTemp <> "" Then '判断是否选中历史条件或输入条件进行查询

        sSqlSel = "select * from zhcx_lscxtj where czyh='" & strczyh & "' and cxlx= '" & msFieldSource & "' and cxtj='" & msTotalTemp & "'"

        lresult = mRequestdb.ExcuteQuery(sSqlSel)
        If lresult = 4 Then   '判断是否有重复的历史查询条件，如果没有则添加到下拉框并存盘


            ReDim sSqlIns(0 To Combolscxtj.ListCount - 1)
            ReDim sSqlDel(0)
            sSqlDel(0) = "delete from zhcx_lscxtj where czyh='" & strczyh & "' and cxlx='" & msFieldSource & "'"
            Call mRequestdb.ExcuteOperation(sSqlDel)
            For i = 0 To Combolscxtj.ListCount - 1
                strxh = i
                strcxtj = Combolscxtj.List(i)
                strcxyj = Combolscxyj.List(i)
                strcxyj = CheckString(strcxyj)
                sSqlIns(i) = "insert into zhcx_lscxtj (czyh,cxlx,xh,cxtj,sqlyj) values ('" & strczyh & "','" _
                             & msFieldSource & "','" & strxh & "','" & strcxtj & "','" & strcxyj & "')"

            Next
            Call mRequestdb.ExcuteOperation(sSqlIns)
            mrsValueToSelect.Close
        End If
    End If
    

    
    Set mrsValueToSelect = New ADODB.Recordset
    Set mRequestdb.DBRecordset = mrsValueToSelect
    '将查询字段与是否选中字段的标志存入zhcx_dyzd库里
    
    sSqlSel = "select zdxh,zwmc from zhcx_cxcs where cxlx='" & msFieldSource & "' "
    lresult = mRequestdb.ExcuteQuery(sSqlSel)
    If lresult <> 4 Then
    
      
        ReDim sSqlIns(0 To mrsValueToSelect.RecordCount)
        
        
        sSqlIns(0) = "delete from zhcx_dyzd where czyh='" & strczyh & "' AND CXLX='" & msFieldSource & "' "
        mrsValueToSelect.MoveFirst
        
        For j = 1 To mrsValueToSelect.RecordCount
            strxz = 0
            For i = 0 To lstSelectedFields.ListCount - 1
                If lstSelectedFields.List(i) = mrsValueToSelect.Fields("zwmc") Then
                    strxz = 1
                    Exit For
                End If
            Next
            
            sSqlIns(j) = "insert into zhcx_dyzd (czyh,cxlx,zdxh,xz) values ('" & strczyh & "','" _
                          & msFieldSource & "','" & mrsValueToSelect(0) & "','" & strxz & "')"
           
            If j = mrsValueToSelect.RecordCount Then
                Exit For
            End If
            
            If Not mrsValueToSelect.EOF Then
                mrsValueToSelect.MoveNext
            End If
        Next
       
        Call mRequestdb.ExcuteOperation(sSqlIns)
    End If
    
    Screen.MousePointer = vbDefault
    Unload Me
    Exit Sub
QueryErr:
   ' Set fmtNum = Nothing
     '鼠标指针
    Screen.MousePointer = 0
    MsgBox Err.Description

End Sub

Private Sub cmdUpDown_Click(Index As Integer)
    Dim i As Integer
    Dim stemp As String
    
    
    '移动选中的项（或全部）
    Select Case Index
        Case uddUp:
             For i = 1 To lstSelectedFields.ListCount - 1
                If lstSelectedFields.Selected(i) Then
                    stemp = lstSelectedFields.List(i)
                    lstSelectedFields.List(i) = lstSelectedFields.List(i - 1)
                    lstSelectedFields.List(i - 1) = stemp
                    ' Call Swap(lstSelectedFields.List(i), lstSelectedFields.List(i - 1))
                    lstSelectedFields.Selected(i - 1) = True
                    lstSelectedFields.Selected(i) = False
                    
                End If
             Next i
        Case uddDown:
            For i = lstSelectedFields.ListCount - 2 To 0 Step -1
                If lstSelectedFields.Selected(i) Then
                    stemp = lstSelectedFields.List(i)
                    lstSelectedFields.List(i) = lstSelectedFields.List(i + 1)
                    lstSelectedFields.List(i + 1) = stemp
                    lstSelectedFields.Selected(i + 1) = True
                    lstSelectedFields.Selected(i) = False
                End If
             Next i
    End Select
    
    Call lstSelectedFields_Click
    
End Sub

Private Sub Combolscxtj_Click()
    Combolscxyj.ListIndex = Combolscxtj.ListIndex
    cmdClearQuery.Enabled = True
    cmbQuery(3).Enabled = True
    lstQuerySql.Clear
    lstQuerySql.AddItem (Combolscxtj.Text)
    msQuerySql = Combolscxyj.Text
    msTotalTemp = Combolscxtj.Text
End Sub

Private Sub form_KeyDown(KeyCode As Integer, Shift As Integer)
    If KeyCode = vbKeyReturn Then
        Call SendKeys("{TAB}")
    End If
End Sub

Private Sub Form_Load()

    Me.Left = 0
    Me.Top = 0
    
   
    Set mRequestdb = New RequestDB
    
    cmdClearQuery.Enabled = False
    cmdBeginQuery.Enabled = False
    dtpQueryValue.Visible = False
    
    sstabQuery.Tab = 0
    
    txtQueryValue.Visible = True
    cmbQuery(qivalue).Visible = False
    dtpQueryValue.Left = txtQueryValue.Left
    dtpQueryValue.Top = txtQueryValue.Top
    cmbQuery(qivalue).Left = txtQueryValue.Left
    cmbQuery(qivalue).Top = txtQueryValue.Top
    
  
       
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Call cmdQuitQuery_Click
    Set mRequestdb = Nothing
    
End Sub

Private Sub lstFields_DblClick()
    cmdMove_Click mdRight
End Sub

Private Sub lstSelectedFields_Click()
    
    Dim i As Integer

   ' cmdUpDown(uddUp).Enabled = False
   ' cmdUpDown(uddDown).Enabled = False
    
    If lstSelectedFields.ListCount <= 0 Then
        cmdUpDown(uddUp).Enabled = False
        cmdUpDown(uddDown).Enabled = False
        Exit Sub
    End If
    
    For i = 0 To lstSelectedFields.ListCount - 1
        If lstSelectedFields.Selected(i) Then
            cmdUpDown(uddUp).Enabled = True
            cmdUpDown(uddDown).Enabled = True
            Exit For
        End If
    Next i
    
    If lstSelectedFields.Selected(0) Then
        cmdUpDown(uddUp).Enabled = False
    End If
    
    If lstSelectedFields.Selected(lstSelectedFields.ListCount - 1) Then
        cmdUpDown(uddDown).Enabled = False
    End If
    
    
End Sub

Private Sub lstSelectedFields_DblClick()
    cmdMove_Click mdLeft
End Sub

Private Sub txtQueryValue_Change()
    Call CheckAddQueryBtnEnabled
End Sub


'******************************************************************************
'FUNCTION: ReadValueToListControl
'PARAM:  objCombo As ComboBox --- comboBox控件
'        sFields1 As String --
'        sFields2 As string  --
'
'功能:
'******************************************************************************
Private Sub ReadValueToListControl(objCombo As Object, _
                                  objRecordset As ADODB.Recordset, _
                                  sField1 As String, _
                                  Optional sField2 As String = "")
On Error GoTo ReadErr
    Dim i As Integer
    
    objCombo.Clear
    objRecordset.MoveFirst
    
    Do While Not objRecordset.EOF
        If sField2 <> "" Then
            objCombo.AddItem (objRecordset.Fields(sField1) & "-" & objRecordset.Fields(sField2))
        Else
            objCombo.AddItem (objRecordset.Fields(sField1))
        End If
        objRecordset.MoveNext
    Loop
    
Exit Sub

ReadErr:
    On Error GoTo 0
                                
End Sub



'******************************************************************************
'FUNCTION: CreateSql
'功能:    生成查询语句。
'******************************************************************************
Public Function CreateSql() As String
    Dim sSql As String
    Dim stemp  As String
    Dim i As Integer
    
    sSql = "Select"
    
    '查询字段
    For i = 0 To lstSelectedFields.ListCount - 1
        stemp = GetFieldByChinese(lstSelectedFields.List(i))
        sSql = sSql & " " & stemp
        sSql = sSql & " as " & lstSelectedFields.List(i) & ","
    Next i
    
    sSql = Mid$(sSql, 1, Len(sSql) - 1)
    
    sSql = sSql & " " & "From " & msQuerySource
    
    '查询条件
    If msQuerySql <> "" Then
        sSql = sSql & " " & "Where "
        CreateSql = sSql & msQuerySql
        
    Else
        CreateSql = sSql
    End If
    
End Function


'******************************************************************************
'FUNCTION: GetFieldByChinese
'PARAM:    Chinese As String
'RETURN:   Field Name
'
'功能:     通过中文描述，得到数据库中的字段名
'******************************************************************************
Private Function GetFieldByChinese(Chinese As String) As String

    GetFieldByChinese = ""
    mrsQueryParam.MoveFirst
    Do While Not mrsQueryParam.EOF
        If mrsQueryParam.Fields("zwmc") = Chinese Then
            GetFieldByChinese = mrsQueryParam.Fields("zdmc")
            Exit Function
        End If
        mrsQueryParam.MoveNext
    Loop
    
End Function

Private Sub txtQueryValue_KeyPress(KeyAscii As Integer)
    If CInt(cmbQuery(qiOperation).Tag) = CInt(qftNumber) Then
       Call ifDigital(txtQueryValue.Text, _
                          KeyAscii, _
                          True)
    End If
End Sub