frmquery.frm

朋友给的

    '加入条件
    txtCondition.SetFocus
    SendWord txtCondition, scon

End Sub

Private Sub cmdAnd_Click()
    txtCondition.SetFocus
    SendWord txtCondition, " And "

End Sub

Private Sub cmdClear_Click()
    '清空条件
    txtCondition = ""
    msfResult.Rows = 1
End Sub
Private Sub cmdL_Click()
    txtCondition.SetFocus
    SendWord txtCondition, "("

End Sub

Private Sub cmdOr_Click()
    txtCondition.SetFocus
    SendWord txtCondition, " Or "

End Sub

Private Sub cmdPrint_Click()
'    frmPrint.Refresh
    If msfResult.Rows = 1 Then
        If MsgBox("查询结果为空，还要打印吗？", vbYesNo + vbDefaultButton2 + vbQuestion, "提示") = vbNo Then
            Exit Sub
        End If
    End If
    frmPrint.ShowMe True, msfResult, , Me.Caption, Me.Caption
End Sub

Private Function ShowQueryResult()
    On Error GoTo err_label
    Dim sql As String, iCnt As Integer, strSort As String, sqlHz As String
    Dim rstx As ADODB.Recordset, icnt1 As Integer
    Dim i As Integer, sHzfs As String
    Dim bAdjust As Boolean

    For i = 1 To lvwFieldName.ListItems.count
        If lvwFieldName.ListItems(i).Checked = True Then Exit For
    Next i
    If i = lvwFieldName.ListItems.count + 1 Then
        MsgBox "至少选择一个字段.", vbInformation + vbOKOnly
        Exit Function
    End If
    '-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
    '选择字段
    '-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
    i = 0
    For iCnt = 1 To lvwFieldName.ListItems.count
        If lvwFieldName.ListItems(iCnt).Checked = True Then
            lvwFieldName.ListItems(iCnt).Tag = i
            i = i + 1
            sql = sql & IIf(Len(sql) > 0, ",", "") & lvwFieldName.ListItems(iCnt).Text
        Else
            lvwFieldName.ListItems(iCnt).Tag = -1
        End If
    Next iCnt

    sql = "select " & sql & " from " & strOri '& " order by " & lvwFieldName.ListItems(1).Text
    '-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
    '条件
    '-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
    If txtCondition <> "" Then sql = sql & " where " & txtCondition
    '-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
    '排序
    '-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
    strSort = ""
    For iCnt = 1 To lvwFieldName.ListItems.count
        If lvwFieldName.ListItems(iCnt).SubItems(1) <> "" Then
            strSort = strSort & IIf(strSort = "", "", ",") & lvwFieldName.ListItems(iCnt).Text
        End If
        If lvwFieldName.ListItems(iCnt).SubItems(1) = "降序" Then
            strSort = strSort & " Desc"
        End If
    Next iCnt

    If strSort <> "" Then sql = sql & " Order by " & strSort

    '-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
    '打开记录集
    '-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
    Dim sc As String
    sc = Me.Caption
    Me.Enabled = False
    Me.Caption = sc & "-打开记录集"
    'DoEvents

    Set rstx = New ADODB.Recordset
    rstx.CursorLocation = adUseClient   '加上这一句
    rstx.Open sql, gCnn, adOpenStatic, adLockReadOnly

''    ProgressOn pgb, 1
    'Set rstX = dbyggl.OpenRecordset(sql, dbOpenSnapshot)
    msfResult.Rows = 1
    msfResult.Refresh
    msfResult.Cols = rstx.Fields.count
'    lblNum.Caption = "符合条件的记录共找到 " & rstx.RecordCount & " 条"
    If rstx.RecordCount = 0 Then
        Me.Caption = sc
        Me.Enabled = True
        Me.SetFocus
        Exit Function
    End If
    
    '填网格
    With msfResult
        .Row = 0
        For iCnt = 0 To rstx.Fields.count - 1
            .Col = iCnt
            .CellAlignment = flexAlignCenterCenter
            .ColWidth(iCnt) = 960 'IIf(IsNumeric(msfResult.ColData(icnt)), CInt(msfResult.ColData(icnt)), 960)
            .TextArray(iCnt) = rstx.Fields(iCnt).name
        Next iCnt
    End With
    iCnt = 1
    Me.Caption = sc & "-读取数据"
    
    If rstx.RecordCount > 10000 Then
        msfResult.Rows = 10000
        MsgBox "记录数目超过10000条,最多只能10000。"
    Else
        msfResult.Rows = rstx.RecordCount + 1 'msfResult.Rows + 1
    End If

    isCancel = False
    For iCnt = 1 To msfResult.Rows - 1

        For icnt1 = 0 To msfResult.Cols - 1
            msfResult.TextMatrix(iCnt, icnt1) = CStr(IIf(IsNull(rstx.Fields(icnt1)), "", rstx.Fields(icnt1)))
            If rstx.Fields(icnt1).Type = adBoolean Then
                If msfResult.TextMatrix(iCnt, icnt1) = "False" Then
                    msfResult.TextMatrix(iCnt, icnt1) = "否"
                ElseIf msfResult.TextMatrix(iCnt, icnt1) = "True" Then
                    msfResult.TextMatrix(iCnt, icnt1) = "是"
                End If
            End If
        Next icnt1
        DoEvents
        If isCancel Then
            isCancel = False
            GoTo e_while
        End If
        rstx.MoveNext
    Next iCnt

e_while:
    
    rstx.Close
    
    If bAdjust = False Then AdjustGridWidth msfResult
    Me.Caption = sc
    Me.Enabled = True
    Me.SetFocus
    'Debug.Print "e " & CStr(Time)
    frmQuery.Caption = strOri
    Exit Function
err_label:
    sql = "发生错误,有以下可能:" & vbCr
    sql = "    查询条件语法错误" & vbCr
    Me.Enabled = True
    Me.Caption = sc
    Me.SetFocus
    ST.Tab = 0
    MsgBox sql, vbInformation + vbOKOnly
    Exit Function
End Function

Private Sub cmdR_Click()
    txtCondition.SetFocus
    SendWord txtCondition, ")"

End Sub

Private Sub cmdValue_Click()
    '清空
    cmbValue.Clear
    If cmbField = "" Then
        MsgBox "请选择要查询值的字段。", vbInformation + vbOKOnly, "提示"
        Exit Sub
    End If
    Dim rstx As ADODB.Recordset, i As Integer
    Dim sc As String
    sc = Me.Caption
    Me.Enabled = False
    Me.Caption = sc & "-打开记录集"
    DoEvents
    Set rstx = New ADODB.Recordset
    rstx.CursorLocation = adUseClient   '加上这一句
    rstx.Open "select distinct " & cmbField.Text & " from " & strOri & " order by " & cmbField.Text, gCnn, adOpenStatic, adLockReadOnly
    If rstx.RecordCount = 0 Then
        Me.Caption = sc
        Me.Enabled = True
        Exit Sub
    End If
    'rstX.MoveLast
    Me.Caption = sc & "-接收数据"
    rstx.MoveFirst
    '填入下拉框
    While Not rstx.EOF
        Me.Caption = Me.Caption & "."
        If Len(Me.Caption) > 60 Then Me.Caption = sc & "-接收数据"
        DoEvents
        If Not IsNull(rstx.Fields(0)) Then cmbValue.AddItem rstx.Fields(0)
        rstx.MoveNext
    Wend
    Me.Caption = sc & "-关闭记录集"
    DoEvents
    rstx.Close
    Me.Caption = sc
    Me.Enabled = True
    Me.SetFocus
End Sub

Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)
    Dim shiftkey As Long
    Dim Index As Long
    Dim i As Long
    
    On Error Resume Next
    
    shiftkey = Shift And 7
    Select Case shiftkey
        Case 1 '或 vbShiftMask

        Case 2 '或 vbCtrlMask
            If ST.Tab <> 0 Then Exit Sub
            Index = lvwFieldName.SelectedItem.Index
            lvwFieldName.Visible = False
            If KeyCode = Asc("a") Or KeyCode = Asc("A") Then
                For i = 1 To lvwFieldName.ListItems.count
                    lvwFieldName.ListItems(i).Checked = True
                Next i
            End If
            If KeyCode = Asc("d") Or KeyCode = Asc("D") Then
                For i = 1 To lvwFieldName.ListItems.count
                    lvwFieldName.ListItems(i).Checked = False
                Next i
            End If
            lvwFieldName.ListItems(Index).Selected = True
            lvwFieldName.Visible = True
            KeyCode = 0
        Case 4 '或 vbAltMask

    End Select

End Sub

Private Sub Form_Unload(Cancel As Integer)
    frmMain.SetFocus
End Sub

'Public Function ShowQuery(sTitle As String, ByVal sQueryNameOrSql As String, Optional sCondition As String = "", Optional iFieldReturn As Integer = 0, Optional sTempQueryName As String = "Temp_Query") As Variant
'    'sTitle     窗口的标题
'    'sQueryNameOrSql 查询的名字或SQL语句
'    'sTempQueryName 临时查询的名称
'    On Error GoTo Err_Handle
'    Dim fm As frmQuery
'    Dim iTemp As Long 'TEMP的INDEX
'    Dim i As Long
'    Dim isQuery As Boolean
'    Dim s As String
'    Load frmQuery
'    frmQuery.Visible = False
'    iTemp = -1
'
'    sQueryNameOrSql = UCase(sQueryNameOrSql)
'    If InStr(1, sQueryNameOrSql, "SELECT") > 0 Then
'        isQuery = False
'    Else
'        isQuery = True
'    End If
'    '是SQL
'    If Not isQuery Then
'        s = CLng(gServerTime) & Mid(CDbl(gServerTime), Len(CStr(CLng(gServerTime))) + 2)
'            On Error Resume Next
'            gcnn.Execute "drop view " & sTempQueryName & s
'            On Error GoTo 0
'        sQueryNameOrSql = "create view " & sTempQueryName & s & " as " & sQueryNameOrSql
'        gcnn.Execute sQueryNameOrSql
'        sQueryNameOrSql = sTempQueryName & s
'    End If
'
'    '打开新FORM
'    Set fm = New frmQuery
'    fm.Visible = False
'    fm.Refresh
'
'    With fm
'        .Caption = sTitle
'        .strOri = sQueryNameOrSql
'        .Tag = sTitle
'        SetFormControlsProperty fm, 3
'        lvwFieldName.Checkboxes = True
'        '填字段
'
'        .FillFieldName
'        If iFieldReturn > 0 Then
'            .msfResult.SelectionMode = flexSelectionByRow
'        End If
'
'        .txtCondition = sCondition
'        .Show
'        .ZOrder 0
'        If .txtCondition <> "" Then
'            .ST.Tab = 1
'        End If
'    End With
'    Exit Function
'Err_Handle:
'    ErrMessage
'End Function

Sub SendWord(sText As TextBox, scon As String)
    Dim sMSG As String
    With sText
        sMSG = Left(.Text, .SelStart) + scon
        .Text = Left(.Text, .SelStart) + scon + Right(.Text, Len(.Text) - .SelLength - .SelStart)
        .SelStart = Len(sMSG)
    End With
End Sub

Private Sub SpBExport_Click()
    cdlFile.ShowSave
    Screen.MousePointer = 11
    ChangToXLS msfResult, cdlFile.Filename, 2
    Screen.MousePointer = 0
End Sub

Public Sub ST_Click(PreviousTab As Integer)
    If PreviousTab = ST.Tab Then
        Exit Sub
    End If
    If ST.Tab = 1 Then
        msfResult.Visible = True
        Me.WindowState = vbMaximized
        Me.Refresh
        Screen.MousePointer = 11
        ShowQueryResult
        Screen.MousePointer = 0
    Else
        Me.Refresh
        msfResult.Visible = False
'        Me.WindowState = vbNormal
    End If
End Sub