frmgrid.frm

中专学校的学生操行分管理系统,包含了网络查询的功能

            Set myNodeList = myReport.childNodes
            optCol(CInt(myNodeList.Item(2).Text)).Value = True
            tvReport.Nodes.Clear
            strName = myNodeList.Item(0).Text
            strKey = myNodeList.Item(1).Text
            tvReport.Nodes.Add , , strKey, strName
            For Each myNode In myNodeList
                Select Case myNode.baseName
                    Case "node"
                        strColName = myNode.childNodes.Item(0).Text
                        strColKey = myNode.childNodes.Item(1).Text
                        tvReport.Nodes.Add strKey, tvwChild, strColKey, strColName
                        If myNode.childNodes.length > 2 Then
                            intCount = myNode.childNodes.length
                            For i = 2 To intCount - 1
                                tvReport.Nodes.Add strColKey, tvwChild, myNode.childNodes.Item(i).childNodes.Item(1).Text, myNode.childNodes.Item(i).childNodes.Item(0).Text
                            Next i
                        End If
                End Select
            Next
            tvReport.Nodes(1).Expanded = True
        End If
    Next
    Set objXml = Nothing
End Sub

'*************************************************
'保存TREEVIEW中的列标头结构到XML文件中
'*************************************************
Private Sub SaveColTree(ByVal strFile As String, ByVal strReport As String, ByVal strID As String)
    Dim objXml As New DOMDocument
    Dim myReportList As IXMLDOMNodeList
    Dim myReport As IXMLDOMNode
    Dim newNode As IXMLDOMNode
    Dim myNode As IXMLDOMNode
    Dim myNodeChild As IXMLDOMNode
    Dim myCol As IXMLDOMNode
    Dim myName As IXMLDOMAttribute
    Dim strName As String
    Dim strKey As String
    Dim i, j As Integer
    Dim bIsExist As Boolean

    bIsExist = False
    strName = strReport
    strKey = tvReport.Nodes(1).Key

    objXml.Load strFile
    Set newNode = objXml.createNode(NODE_ELEMENT, "report", "")
    Set myName = objXml.createAttribute("ID")
    myName.Text = strID
    newNode.Attributes.setNamedItem myName
    

    Set myNode = objXml.createNode(NODE_ELEMENT, "name", "")
    myNode.Text = strName
    newNode.appendChild myNode

    Set myNode = objXml.createNode(NODE_ELEMENT, "key", "")
    myNode.Text = strKey
    newNode.appendChild myNode

    Set myNode = objXml.createNode(NODE_ELEMENT, "style", "")
    myNode.Text = IIf(optCol(0).Value, "0", "1")
    newNode.appendChild myNode

'***********************************************************************
'双层列头结构
    i = tvReport.Nodes(1).Child.FirstSibling.Index
    Set myNode = objXml.createNode(NODE_ELEMENT, "node", "")
    Set myCol = objXml.createNode(NODE_ELEMENT, "colname", "")
    myCol.Text = tvReport.Nodes(i).Text
    myNode.appendChild myCol
    Set myCol = objXml.createNode(NODE_ELEMENT, "colkey", "")
    myCol.Text = tvReport.Nodes(i).Key
    myNode.appendChild myCol
    If tvReport.Nodes(i).children > 0 Then
        j = tvReport.Nodes(i).Child.FirstSibling.Index
        Set myNodeChild = objXml.createNode(NODE_ELEMENT, "node", "")
        Set myCol = objXml.createNode(NODE_ELEMENT, "colname", "")
        myCol.Text = tvReport.Nodes(j).Text
        myNodeChild.appendChild myCol
        Set myCol = objXml.createNode(NODE_ELEMENT, "colkey", "")
        myCol.Text = tvReport.Nodes(j).Key
        myNodeChild.appendChild myCol
        myNode.appendChild myNodeChild
        Do While j <> tvReport.Nodes(j).LastSibling.Index
            Set myNodeChild = objXml.createNode(NODE_ELEMENT, "node", "")
            Set myCol = objXml.createNode(NODE_ELEMENT, "colname", "")
            myCol.Text = tvReport.Nodes(j).Next.Text
            myNodeChild.appendChild myCol
            Set myCol = objXml.createNode(NODE_ELEMENT, "colkey", "")
            myCol.Text = tvReport.Nodes(j).Next.Key
            myNodeChild.appendChild myCol
            myNode.appendChild myNodeChild
            j = tvReport.Nodes(j).Next.Index
        Loop
    End If
    newNode.appendChild myNode

    Do While i <> tvReport.Nodes(1).Child.LastSibling.Index
        Set myNode = objXml.createNode(NODE_ELEMENT, "node", "")
        Set myCol = objXml.createNode(NODE_ELEMENT, "colname", "")
        myCol.Text = tvReport.Nodes(i).Next.Text
        myNode.appendChild myCol
        Set myCol = objXml.createNode(NODE_ELEMENT, "colkey", "")
        myCol.Text = tvReport.Nodes(i).Next.Key
        myNode.appendChild myCol
        If tvReport.Nodes(i).Next.children > 0 Then
            j = tvReport.Nodes(i).Next.Child.FirstSibling.Index
            Set myNodeChild = objXml.createNode(NODE_ELEMENT, "node", "")
            Set myCol = objXml.createNode(NODE_ELEMENT, "colname", "")
            myCol.Text = tvReport.Nodes(j).Text
            myNodeChild.appendChild myCol
            Set myCol = objXml.createNode(NODE_ELEMENT, "colkey", "")
            myCol.Text = tvReport.Nodes(j).Key
            myNodeChild.appendChild myCol
            myNode.appendChild myNodeChild
            Do While j <> tvReport.Nodes(j).LastSibling.Index
                Set myNodeChild = objXml.createNode(NODE_ELEMENT, "node", "")
                Set myCol = objXml.createNode(NODE_ELEMENT, "colname", "")
                myCol.Text = tvReport.Nodes(j).Next.Text
                myNodeChild.appendChild myCol
                Set myCol = objXml.createNode(NODE_ELEMENT, "colkey", "")
                myCol.Text = tvReport.Nodes(j).Next.Key
                myNodeChild.appendChild myCol
                myNode.appendChild myNodeChild
                j = tvReport.Nodes(j).Next.Index
            Loop
        End If
        i = tvReport.Nodes(i).Next.Index
        newNode.appendChild myNode
    Loop
'**********************************************************************

    Set myReportList = objXml.getElementsByTagName("myfile").Item(0).childNodes
    For Each myReport In myReportList
        If myReport.Attributes.Item(0).Text = strID Then
            If MsgBox("报表‘" & strReport & "’列标头结构已经存在，是否要替换？", vbYesNo + vbQuestion) = vbYes Then
                bIsExist = True
                objXml.getElementsByTagName("myfile").Item(0).replaceChild newNode, myReport
            End If
        End If
    Next
    If Not bIsExist Then objXml.getElementsByTagName("myfile").Item(0).appendChild newNode
    objXml.Save strFile
    Set objXml = Nothing
End Sub

'*************************************************
'更新LISTVIEW中的数据
'*************************************************
Private Sub RefreshListView()
    Dim itemReturn As ListItem
    Dim intColCount As Integer
    Dim i As Integer
    
    On Error Resume Next
    
    lvReport.ListItems.Clear
    intColCount = grdReport.Columns.Count
    For i = 0 To intColCount - 1
        Set itemReturn = lvReport.ListItems.Add(, _
            "Col" & CStr(i), grdReport.Columns(i).Caption)
'        itemReturn.Checked = Not (CInt(grdReport.Columns(i).Width / 56.7) = 0)
    Next i
End Sub

'*************************************************
'更新TREEVIEW中的数据
'*************************************************
Private Sub RefreshTreeView(ByVal Index As Integer)
    Dim itemReturn As ListItem
    Dim intColCount As Integer
    Dim i As Integer
    
    On Error Resume Next
    
    tvReport.Nodes.Clear
    tvReport.Nodes.Add , , "Report1", strName
    intColCount = lvReport.ListItems.Count
    If Index = 0 Then
        For i = 1 To intColCount
            tvReport.Nodes.Add "Report1", tvwChild, lvReport.ListItems(i).Key, lvReport.ListItems(i).Text
        Next i
        tvReport.Nodes(1).Expanded = True
    End If
End Sub

'*************************************************
'检查TREEVIEW中的列标头结构
'*************************************************
Private Function CheckColTree() As Boolean
'检查物TREEVIEW中列标头结构的正确性
    Dim i, j, k As Integer
    Dim intError As Integer
    Dim intCount As Integer
    Dim colKey() As Integer
    
    If tvReport.Nodes(1).children = 0 Then
        intError = 1
        GoTo ErrorHandle
    End If
    intCount = lvReport.ListItems.Count
    ReDim colKey(intCount)
    k = 0
    With tvReport.Nodes(1).Child
        i = .FirstSibling.Index
        If Mid$(tvReport.Nodes(i).Key, 1, 4) = "Item" Then
            If tvReport.Nodes(i).children > 0 Then
                j = tvReport.Nodes(i).Child.FirstSibling.Index
                k = k + 1
                colKey(k) = CInt(Mid$(tvReport.Nodes(j).Key, 4))
                Do While j <> tvReport.Nodes(j).LastSibling.Index
                    k = k + 1
                    colKey(k) = CInt(Mid$(tvReport.Nodes(j).Next.Key, 4))
                    j = tvReport.Nodes(j).Next.Index
                Loop
            Else
                intError = 0
                GoTo ErrorHandle
            End If
        Else
            k = k + 1
            colKey(k) = CInt(Mid$(tvReport.Nodes(i).Key, 4))
        End If

        Do While i <> .LastSibling.Index
            If Mid$(tvReport.Nodes(i).Next.Key, 1, 4) = "Item" Then
                If tvReport.Nodes(i).Next.children > 0 Then
                    j = tvReport.Nodes(i).Next.Child.FirstSibling.Index
                    k = k + 1
                    colKey(k) = CInt(Mid$(tvReport.Nodes(j).Key, 4))
                    Do While j <> tvReport.Nodes(j).LastSibling.Index
                        k = k + 1
                        colKey(k) = CInt(Mid$(tvReport.Nodes(j).Next.Key, 4))
                        j = tvReport.Nodes(j).Next.Index
                    Loop
                Else
                    intError = 0
                    GoTo ErrorHandle
                End If
            Else
                k = k + 1
                colKey(k) = CInt(Mid$(tvReport.Nodes(i).Next.Key, 4))
            End If
            i = tvReport.Nodes(i).Next.Index
        Loop
    End With
    
    If k < intCount Then
        intError = 1
        GoTo ErrorHandle
    End If
    
    For i = 1 To intCount - 1
        If colKey(i) >= colKey(i + 1) Then
            intError = 2
            GoTo ErrorHandle
        End If
    Next
    CheckColTree = True
    Exit Function
ErrorHandle:
    Me.MousePointer = 0
    CheckColTree = False
    Select Case intError
        Case 0  '有新建列的下层没有数据列
            MsgBox "在自定义列的下层没有数据列，请检查！", vbOKOnly + vbExclamation, "错误"
        Case 1  '有数据列没有被选择
            MsgBox "有数据列没有被选择，请检查！", vbOKOnly + vbExclamation, "错误"
        Case 2  '数据列的排列次序不对
            MsgBox "数据列的排列次序不对，请检查！", vbOKOnly + vbExclamation, "错误"
    End Select
End Function

Private Sub adoCalc_Error(ByVal ErrorNumber As Long, Description As String, ByVal Scode As Long, ByVal source As String, ByVal HelpFile As String, ByVal HelpContext As Long, fCancelDisplay As Boolean)
    fCancelDisplay = True
End Sub

Private Sub adoReport_Error(ByVal ErrorNumber As Long, Description As String, ByVal Scode As Long, ByVal source As String, ByVal HelpFile As String, ByVal HelpContext As Long, fCancelDisplay As Boolean)
    fCancelDisplay = True
End Sub

Private Sub cboCalc_Click()
    lvReport.SelectedItem.SubItems(1) = cboCalc.Text
    If cboCalc.ListIndex = 4 Or cboCalc.ListIndex = 5 Then
        cboPlace.Enabled = True
    Else
        cboPlace.Enabled = False
    End If
End Sub

Private Sub cboCalc_KeyDown(KeyCode As Integer, Shift As Integer)
    If KeyCode = vbKeyLeft Then lvReport.SetFocus
    If KeyCode = vbKeyRight Then cboPlace.SetFocus
End Sub

Private Sub cboPlace_Click()
    lvReport.SelectedItem.SubItems(2) = cboPlace.Text
End Sub

Private Sub cboPlace_KeyDown(KeyCode As Integer, Shift As Integer)
    If KeyCode = vbKeyLeft Then cboCalc.SetFocus
End Sub

Private Sub cmdClose_Click()
    SaveColWidth strWidthFile, strName, strReportID
    Unload Me
End Sub

Private Sub cmdHelp_Click()
    frmQueryHelp.Show vbModal, Me
End Sub

Private Sub cmdPrint_Click()
    Dim i As Integer, iPlace As Integer, iCount As Integer, iPos As Integer
    Dim strCalc As String, strTable As String
    
    Me.MousePointer = 11
    
    If optCol(1).Value Then
        If Not CheckColTree Then Exit Sub
    End If
    
    iCount = lvReport.ListItems.Count
    bReportCalc = False
    For i = 1 To iCount
        If lvReport.ListItems("Col" & CStr(i - 1)).SubItems(2) = "" Then
            iPlace = 2
        Else
            iPlace = CInt(lvReport.ListItems("Col" & CStr(i - 1)).SubItems(2))
        End If
        Select Case lvReport.ListItems("Col" & CStr(i - 1)).SubItems(1)
            Case ""
                strCalc = strCalc & ",NULL"
            Case "求和"
                strCalc = strCalc & ",Round(Sum([" & adoReport.Recordset.Fields(i - 1).Name & "])," & CStr(iPlace) & ")"
                bReportCalc = True
            Case "计数"
                strCalc = strCalc & ",Count([" & adoReport.Recordset.Fields(i - 1).Name & "])"
                bReportCalc = True
            Case "最大值"
                strCalc = strCalc & ",Max([" & adoReport.Recordset.Fields(i - 1).Name & "])"
                bReportCalc = True
            Case "最小值"
                strCalc = strCalc & ",Min([" & adoReport.Recordset.Fields(i - 1).Name & "])"