query.frm

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

        
    End If
    
    Set mrsQueryResult = New adodb.Recordset
    Set mrequestdb.DBRecordset = mrsQueryResult

    mrequestdb.ExcuteQuery (CreateSql)
    '鼠标指针
    Screen.MousePointer = 0
    
   
    Set frmQueryResult.mshfgQueryResult.DataSource = mrsQueryResult
    Set frmQueryResult.rsResult = mrsQueryResult
    frmQueryResult.Caption = Me.Caption & "结果"
    frmQueryResult.Tag = mQueryPrintType
    frmQueryResult.msFieldSource = msFieldSource
    If frmQueryResult.msFieldSource = "2019" Then
        frmQueryResult.CmdShowDetail.Enabled = False
    End If
    
     '将打印字段的列宽与行高取出
    Dim mRecordset As 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 = 0 Then '判断打印尺寸表里是否为空
        
        For i = 1 To frmQueryResult.mshfgQueryResult.Cols - 1
            sZwmc(i) = frmQueryResult.mshfgQueryResult.TextMatrix(0, i)
            mRecordset.Filter = " zdmc='" & sZwmc(i) & "' "
            If mRecordset.RecordCount > 0 Then
                frmQueryResult.mshfgQueryResult.ColWidth(i) = mRecordset.Fields("zdkd")
            End If
        Next
        
        mRecordset.Filter = ""
        If mrsQueryResult.RecordCount > 0 Then
            For i = 0 To frmQueryResult.mshfgQueryResult.Rows - 1
                frmQueryResult.mshfgQueryResult.RowHeight(i) = mRecordset.Fields("zdgd")
            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()
  Unload Me
End Sub

Private Sub SaveQueryInfo()

On Error GoTo QueryErr
    Dim i As Integer
    Dim j As Integer
    Dim sSqlIns() As String

    Dim sSqlSel As String
'    Dim strxh As String

    Dim lresult As Long

    Dim strxz As String

'    Dim strcxtj As String
'    Dim strcxyj As String

    '鼠标指针
    Screen.MousePointer = 11
    
    
'
'     ReDim sSqlIns(0 To Combolscxtj.ListCount)
'     sSqlIns(0) = "delete from zhcx_lscxtj where czyh='" & strczyh & "' and cxlx='" & msFieldSource & "'"
'
'     For i = 0 To Combolscxtj.ListCount - 1
'         strxh = i
'         strcxtj = Combolscxtj.List(i)
'         strcxyj = Combolscxyj.List(i)
'         strcxyj = CheckString(strcxyj)
'         sSqlIns(i + 1) = "insert into zhcx_lscxtj (czyh,cxlx,xh,cxtj,sqlyj) values ('" & strczyh & "','" _
'                      & msFieldSource & "','" & strxh & "','" & strcxtj & "','" & strcxyj & "')"
'
'     Next
'
'     Call mrequestdb.ExcuteOperation(sSqlIns)


    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 = 0 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

    Exit Sub

QueryErr:
     '鼠标指针
    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
    If Combolscxtj.Text <> "" Then
        cmbQuery(3).Enabled = True
    End If
    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)
    SaveQueryInfo
    Set mrequestdb = Nothing
    Set mrsValueToSelect = 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
    Debug.Print sSql
End Function


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

    On Error Resume Next
    GetFieldByChinese = ""
    mrsQueryParam.MoveFirst
    Do While Not mrsQueryParam.EOF
        If mrsQueryParam.Fields("zwmc") = Chinese Then
            'Debug.Print mrsQueryParam
            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