frmcommonselectresult.frm

来自「通用书店管理系统」· FRM 代码 · 共 656 行 · 第 1/2 页

       If grdQryResult.GroupColumns.Item(i).ColIndex = ColIndex Then blnExistInGroup = True

    Next i


    If blnExistInGroup Then Exit Sub     '如果选种列是分组列，则不进行排序

    '确定被选种列的数据类型
    intType(grdQryResult.GroupColumns.Count) = 9                        '默认值：字符型9
    If Not IsVacancy(X(0, ColIndex)) Then
       If IsNumeric(X(0, ColIndex)) Then
          intType(grdQryResult.GroupColumns.Count) = 5                    '双精度
       End If
    End If

    ShowErrorMessage "正在排序………………"

    Select Case grdQryResult.GroupColumns.Count
    Case 0
       X.QuickSort 0, X.UpperBound(1), ColIndex, 0, intType(0)
    Case 1
       X.QuickSort 0, X.UpperBound(1), grdQryResult.GroupColumns.Item(0).ColIndex, 0, intType(0), ColIndex, 0, intType(1)
    Case 2
       X.QuickSort 0, X.UpperBound(1), grdQryResult.GroupColumns.Item(0).ColIndex, 0, intType(0), grdQryResult.GroupColumns.Item(1).ColIndex, 0, intType(1), ColIndex, 0, intType(2)
    Case 3
       X.QuickSort 0, X.UpperBound(1), grdQryResult.GroupColumns.Item(0).ColIndex, 0, intType(0), grdQryResult.GroupColumns.Item(1).ColIndex, 0, intType(1), grdQryResult.GroupColumns.Item(2).ColIndex, 0, intType(2), ColIndex, 0, intType(3)
    Case 4
       X.QuickSort 0, X.UpperBound(1), grdQryResult.GroupColumns.Item(0).ColIndex, 0, intType(0), grdQryResult.GroupColumns.Item(1).ColIndex, 0, intType(1), grdQryResult.GroupColumns.Item(2).ColIndex, 0, intType(2), grdQryResult.GroupColumns.Item(3).ColIndex, 0, intType(3), ColIndex, 0, intType(4)
    Case 5
       X.QuickSort 0, X.UpperBound(1), grdQryResult.GroupColumns.Item(0).ColIndex, 0, intType(0), grdQryResult.GroupColumns.Item(1).ColIndex, 0, intType(1), grdQryResult.GroupColumns.Item(2).ColIndex, 0, intType(2), grdQryResult.GroupColumns.Item(3).ColIndex, 0, intType(3), grdQryResult.GroupColumns.Item(4).ColIndex, 0, intType(4), ColIndex, 0, intType(5)
    End Select

    ShowErrorMessage ""
    
    grdQryResult.Refresh

    
End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
    If KeyCode = 13 Then
       Call cmdOK_Click
    ElseIf KeyCode = vbKeyEscape Then
       Call cmdClose_click
    End If
End Sub

Private Sub Form_Load()
    On Error GoTo err
    Dim arrHeader       '存放列头
    Dim i As Integer
    
    varQryResult = ""
    arrResult = Array()      '数组化
    blnOK = False
    
    Set adoPrimaryRS = New ADODB.Recordset
    adoPrimaryRS.Open strQrySQL, cN, adOpenKeyset, adLockReadOnly
    
    Dim lngRow&, lngCol%
    Dim c As TrueOleDBGrid70.Column
    
    '补足列数
    Do While (grdQryResult.Columns.Count < adoPrimaryRS.Fields.Count)
         Set c = grdQryResult.Columns.Add(0)
         With c
              .Visible = True
              
         End With
    Loop
    
    X.ReDim 0, adoPrimaryRS.Recordcount - 1, 0, adoPrimaryRS.Fields.Count - 1
    Set grdQryResult.Array = X
    
    If adoPrimaryRS.Recordcount > 0 Then
        adoPrimaryRS.MoveFirst
        X.LoadRows (adoPrimaryRS.GetRows)   '载入数据
    End If
    
    grdQryResult.ReBind     '显示
    DoEvents
    
    '显示总数
    sb.Panels(1).Text = "共 " & X.UpperBound(1) + 1 & " 行记录"
    
    '---------------------------------------------
    
    DoEvents
    arrHeader = Split(strHeader, "|")
    
    For i = 0 To UBound(arrHeader)
        Me.grdQryResult.Columns(i).Caption = Trim(arrHeader(i))
        
        '自定义宽度
        Me.grdQryResult.Columns(i).Width = Len(arrHeader(i)) * (186.0095 * grdQryResult.Font.Size / 9) + 100
        
    Next i
    
    With Me.grdQryResult
        .AllowColMove = True
        .AllowAddNew = False
        .AllowUpdate = False
        .AllowDelete = False
        .AllowColSelect = True
        .EmptyRows = True
        .ExtendRightColumn = True
        .FilterBar = True
        
    End With
    
    Me.grdQryResult.MarqueeStyle = dbgHighlightRowRaiseCell   ' lzw remark
    
    Exit Sub
err:
    MsgBox err.Description
End Sub

Private Sub Form_Resize()

    Dim sngButtonTop As Single
    Dim sngScaleWidth As Single
    Dim sngScaleHeight As Single

    On Error GoTo Form_Resize_Error
    With Me
        sngScaleWidth = .scaleWidth
        sngScaleHeight = .ScaleHeight - 350

        ' 移动“关闭”按钮到右下角
        With .cmdClose
            sngButtonTop = sngScaleHeight - (.Height + MARGIN_SIZE)
            .Move sngScaleWidth - (.Width + MARGIN_SIZE), sngButtonTop
        End With
        With .cmdOk
            sngButtonTop = sngScaleHeight - (.Height + MARGIN_SIZE)
            .Move _
                sngScaleWidth - (.Width + MARGIN_SIZE) - Me.cmdClose.Width, _
                sngButtonTop
        End With
        
        .grdQryResult.Move MARGIN_SIZE, _
            MARGIN_SIZE, _
            sngScaleWidth - (2 * MARGIN_SIZE), _
            sngButtonTop - (2 * MARGIN_SIZE)
        
        With .cmdPrint
            sngButtonTop = sngScaleHeight - (.Height + MARGIN_SIZE)
            .Move _
                grdQryResult.Left, _
                sngButtonTop
        End With
        
    End With
    Exit Sub

Form_Resize_Error:
    ' 避免负值错误
    Resume Next

End Sub

Private Sub cmdClose_click()
    varQryResult = ""
    arrResult = vbNull
    
    blnOK = False
    
    Unload Me
End Sub

Private Sub grdQryResult_FilterChange()
    
    On Error GoTo err
    
    Dim intCol%
    intCol = Me.grdQryResult.Col
    '进行过滤
        
'    adoPrimaryRS.Filter = adFilterFetchedRecords
    Dim strTemp$, i%
    
    Me.grdQryResult.MarqueeStyle = dbgFloatingEditor
    
    For i = 0 To Me.grdQryResult.Columns.Count - 1
        If Trim(Me.grdQryResult.Columns(i).FilterText) <> "" Then
            Select Case adoPrimaryRS.Fields(i).Type
            Case ADODB.DataTypeEnum.adBSTR, ADODB.DataTypeEnum.adChar, _
                 ADODB.DataTypeEnum.adVarChar, ADODB.DataTypeEnum.adLongVarWChar, ADODB.DataTypeEnum.adVarChar, ADODB.DataTypeEnum.adVarWChar, ADODB.DataTypeEnum.adWChar
                
                '默认后面为统配符
                Dim strValue$
                strValue = Trim(Me.grdQryResult.Columns(i).FilterText)
                If strValue = "*" Or strValue = "**" Or strValue = "***" Then
                    Exit Sub
                Else
                    strTemp = strTemp & IIf(strTemp = "", "", " And ") & adoPrimaryRS.Fields(i).Name & " like '%" & strValue & "%' "
                End If
                
            Case ADODB.DataTypeEnum.adDate, ADODB.DataTypeEnum.adDBDate, ADODB.DataTypeEnum.adDBTime, ADODB.DataTypeEnum.adDBTimeStamp
                
                '当输入的值为非日期型变量时，不进行处理
                If IsDate(Me.grdQryResult.Columns(i).FilterText) Then
                    strTemp = strTemp & IIf(strTemp = "", "", " And ") & adoPrimaryRS.Fields(i).Name & " like '" & Me.grdQryResult.Columns(i).FilterText & "' "
                Else
                    Exit Sub
                End If
            Case Else
                 
                 '当输入特殊符号时，不进行处理
                 Select Case Trim(Me.grdQryResult.Columns(Me.grdQryResult.Col).FilterText)
                 Case "<", ">", ">=", "<=", "<>", "="
                     Exit Sub
                 End Select
                 
                 strTemp = strTemp & IIf(strTemp = "", "", " And ") & adoPrimaryRS.Fields(i).Name & " " & Me.grdQryResult.Columns(i).FilterText & " "
            End Select
        End If
    Next i
    If strTemp = "" Then
        adoPrimaryRS.Filter = adFilterNone
    Else
        adoPrimaryRS.Filter = strTemp
    End If
    
    If adoPrimaryRS.Recordcount > 0 Then
        adoPrimaryRS.MoveFirst
        X.LoadRows (adoPrimaryRS.GetRows)   '载入数据
        grdQryResult.Refresh
        grdQryResult.MoveLast
        grdQryResult.MoveFirst
        
        
    End If
    
    sb.Panels(1).Text = "共 " & X.UpperBound(1) + 1 & " 行记录"
    
    Me.grdQryResult.Col = intCol
    Me.grdQryResult.SelStart = LenB(StrConv(Me.grdQryResult.Columns(intCol).FilterText, vbFromUnicode)) + 1
    
    DoEvents
    Exit Sub
    
err:
    MsgBox "不合法的输入！"
End Sub



Private Sub grdQryResult_HeadClick(ByVal ColIndex As Integer)
    Dim intSplit%
        
    If X.UpperBound(1) < 0 Then Exit Sub
    
    If grdQryResult.GroupColumns.Count > 0 Then intSplit = 1
    If grdQryResult.Splits(intSplit).SelEndCol = -1 Then
        MsgBox "请选择要排序的列！": Exit Sub
    Else
        If grdQryResult.Splits(intSplit).SelEndCol > grdQryResult.Splits(intSplit).SelStartCol Then
            ShowErrorMessage "如果要进行多列排序，请把优先排序列进行分组后再选种某列进行排序！": Exit Sub
        Else
            ColIndex = grdQryResult.Splits(intSplit).SelEndCol
        End If
    End If
    
    Dim intType() As Integer
    Dim i%
    Dim blnExistInGroup As Boolean   '判断选种列是否是分组列

    ReDim intType(grdQryResult.GroupColumns.Count)

    '确定分组列的数据类型
    For i = 0 To grdQryResult.GroupColumns.Count - 1
       intType(i) = 9
       If Not IsVacancy(X(0, grdQryResult.GroupColumns.Item(i).ColIndex)) Then
           If IsNumeric(X(0, grdQryResult.GroupColumns.Item(i).ColIndex)) Then
              intType(i) = 5                    '双精度
           End If
       End If

       If grdQryResult.GroupColumns.Item(i).ColIndex = ColIndex Then blnExistInGroup = True

    Next i
    
    If blnExistInGroup Then Exit Sub     '如果选种列是分组列，则不进行排序

    '确定被选种列的数据类型
    intType(grdQryResult.GroupColumns.Count) = 9                        '默认值：字符型9
    If Not IsVacancy(X(0, ColIndex)) Then
       If IsNumeric(X(0, ColIndex)) Then
          intType(grdQryResult.GroupColumns.Count) = 5                    '双精度
       End If
    End If

    ShowErrorMessage "正在排序………………"

    Select Case grdQryResult.GroupColumns.Count
    Case 0
       X.QuickSort 0, X.UpperBound(1), ColIndex, 0, intType(0)
    Case 1
       X.QuickSort 0, X.UpperBound(1), grdQryResult.GroupColumns.Item(0).ColIndex, 0, intType(0), ColIndex, 0, intType(1)
    Case 2
       X.QuickSort 0, X.UpperBound(1), grdQryResult.GroupColumns.Item(0).ColIndex, 0, intType(0), grdQryResult.GroupColumns.Item(1).ColIndex, 0, intType(1), ColIndex, 0, intType(2)
    Case 3
       X.QuickSort 0, X.UpperBound(1), grdQryResult.GroupColumns.Item(0).ColIndex, 0, intType(0), grdQryResult.GroupColumns.Item(1).ColIndex, 0, intType(1), grdQryResult.GroupColumns.Item(2).ColIndex, 0, intType(2), ColIndex, 0, intType(3)
    Case 4
       X.QuickSort 0, X.UpperBound(1), grdQryResult.GroupColumns.Item(0).ColIndex, 0, intType(0), grdQryResult.GroupColumns.Item(1).ColIndex, 0, intType(1), grdQryResult.GroupColumns.Item(2).ColIndex, 0, intType(2), grdQryResult.GroupColumns.Item(3).ColIndex, 0, intType(3), ColIndex, 0, intType(4)
    Case 5
       X.QuickSort 0, X.UpperBound(1), grdQryResult.GroupColumns.Item(0).ColIndex, 0, intType(0), grdQryResult.GroupColumns.Item(1).ColIndex, 0, intType(1), grdQryResult.GroupColumns.Item(2).ColIndex, 0, intType(2), grdQryResult.GroupColumns.Item(3).ColIndex, 0, intType(3), grdQryResult.GroupColumns.Item(4).ColIndex, 0, intType(4), ColIndex, 0, intType(5)
    End Select

    ShowErrorMessage ""
    
    grdQryResult.Refresh

End Sub

Private Sub ShowErrorMessage(strInfo As String)
    Me.sb.Panels(2).Text = strInfo
End Sub

Private Sub grdQryResult_KeyDown(KeyCode As Integer, Shift As Integer)
  If KeyCode = vbKeyDelete Then
     Exit Sub
  End If
End Sub