项目附表显示.frm

财务信息管理系统,适合做毕业论文的人使用

        Else
            If Len(Text) > CInt(GetField(m_iCol, "len")) Then
                iShowMsg "数字超长!"
                Exit Sub
            End If
        End If
        SetContent m_iCol, m_iRow, Text
        
    ElseIf Text <> "" And tp = "日期" Then
        If m_objAid.sCheckDate(Text) = "" Then
            iShowMsg "非法的日期格式!"
            Exit Sub
        Else
            Text = m_objAid.sCheckDate(Text)
        End If
    ElseIf tp = "逻辑" Then
        If Text <> "0" And Text <> "1" Then
            iShowMsg "逻辑型只能填写0或1"
            Exit Sub
        End If
    ElseIf Text <> "" Then
        If Len(Text) > CInt(GetField(m_iCol, "len")) Then
            iShowMsg "字符串超长!"
            Exit Sub
        End If
    End If
    SetContent m_iCol, m_iRow, Text
    If tp = "数字" Then
        GetSum
    End If
    approve = 1
End Sub

Private Sub ocxCell_MouseLClick(ByVal Col As Long, ByVal Row As Long, ByVal updn As Long)
    Dim root As IXMLDOMElement
    Dim Node As IXMLDOMElement
    
    m_iRow = Row
    m_iCol = Col
    
    ocxCell.ReadOnly = 1
    
    '不能修改合计行
    If m_objContent Is Nothing Or m_iFlag = 0 Or Row = 0 Or (Row = ocxCell.GetRows(0) - 1 And GetHead("sum") <> "") Then
        Exit Sub
    End If
    
    On Error Resume Next
    Set root = m_objAid.objSelectRootTag(m_objContent)
    Set Node = root.childNodes(m_iRow - 1)
    
    If m_iFlag = 1 And Err.Number = 0 And m_objAid.GetAttributeVal("changed", Node) <> "" Then '增加只能修改那些新增的行
        ocxCell.ReadOnly = 0
    Else
        ocxCell.ReadOnly = 0
    End If  '全部都可以修改
End Sub


'xml操作事件
Public Sub SetHead(sName As String, sValue As String, Optional Node As IXMLDOMElement = Nothing)
    '如果头为空,初始化
    If Node Is Nothing Then
        If m_objHead Is Nothing Then Exit Sub
        Set Node = m_objAid.objSelectRootTag(m_objHead)
    End If
    Node.setAttribute sName, sValue
End Sub

Private Function GetHead(sName As String, Optional Node As IXMLDOMElement = Nothing) As String
    Dim tmp
    If Node Is Nothing Then
        If m_objHead Is Nothing Then Exit Function
        Set Node = m_objAid.objSelectRootTag(m_objHead)
    End If
    
    GetHead = m_objAid.GetAttributeVal(sName, Node)
End Function

Private Sub RemoveHead(sName As String, Optional Node As IXMLDOMElement = Nothing)
    If Node Is Nothing Then
        If m_objHead Is Nothing Then Exit Sub
        Set Node = m_objAid.objSelectRootTag(m_objHead)
    End If
    Node.removeAttribute sName
End Sub

Private Sub SetContent(ByVal Col As Integer, ByVal Row As Integer, sValue As String, Optional attr As String = "")
    Dim child As IXMLDOMElement
    Dim root As IXMLDOMElement
    Dim tp As String
    
    '如果数字字段为0,保存为空
    tp = GetField(Col, "type")
    If tp = "数字" And sValue = "0" And Row < ocxCell.GetRows(0) - 1 Then
        sValue = ""
    ElseIf tp = "逻辑" And sValue = "是" Then
        sValue = "1"
    ElseIf tp = "逻辑" And sValue = "否" Then
        sValue = "0"
    End If
    
    Set root = m_objAid.objSelectRootTag(m_objContent)
    Set child = root.childNodes(Row - 1)
    
    child.setAttribute GetField(Col, "name"), sValue
    
    If m_iFlag = 2 Then
        child.setAttribute "changed", "1"
    End If
End Sub
'
Private Function GetContent(ByVal Col As Integer, ByVal Row As Integer, Optional str As String) As String
    Dim child As IXMLDOMElement
    Dim root As IXMLDOMElement
    Dim tp As String
    
    If str <> "" Then
        Col = GetFieldIndex(m_objRef.Item(str))
    End If
    
    tp = GetField(Col, "type")
    
    Set root = m_objAid.objSelectRootTag(m_objContent)
    Set child = root.childNodes(Row - 1)
        
    GetContent = m_objAid.GetAttributeVal(GetField(Col, "name"), child)
    
    If tp = "数字" And Trim(GetContent) = "" Then
        GetContent = 0
    ElseIf tp = "逻辑" And GetContent = "0" Then
        GetContent = "否"
    ElseIf tp = "逻辑" And GetContent <> "0" Then
        GetContent = "是"
    End If
End Function

Private Function GetField(ByVal Col, ByVal sValue As String, Optional offset As Integer = 0) As String
    Dim child As IXMLDOMElement
    
    If IsNumeric(Col) Then
        Set child = m_objAid.objSelectRootTag(m_objHead).childNodes.Item(CInt(Col) - 1 + offset)
    Else
        Set child = m_objAid.objSelectRootTag(m_objHead).selectSingleNode(CStr(Col))
    End If
    
    GetField = m_objAid.GetAttributeVal(sValue, child)
End Function

Private Function GetFieldIndex(ByVal sValue As String, Optional offset As Integer = 0) As Integer
    Dim child As IXMLDOMElement
    
    GetFieldIndex = -1
    Set child = m_objAid.objSelectRootTag(m_objHead).selectSingleNode(sValue)
    GetFieldIndex = CInt(child.getAttribute("index")) - offset
End Function

Private Sub DomToTable()
    If m_objContent Is Nothing Then
        ocxCell.SetRows 1, 0
    Else
        MakeRow
        MakeSum
        GetSum
    End If
    SetButtonState
End Sub


Private Function RowToNode(Row As Integer) As IXMLDOMElement
    Dim colcount As Integer
    Dim i As Integer
    Dim val As String
    
    colcount = m_objAid.iNodeCount(m_objAid.objSelectRootTag(m_objHead))
    If Row < 1 Or Row > ocxCell.GetRows(0) Then
        Exit Function
    End If
    
    Set RowToNode = m_objHead.createElement("item")
    If m_iFlag = 1 Or m_iFlag = 2 Then
        For i = 1 To colcount
            val = Trim(ocxCell.GetCellString(i, Row, 0))
            If val <> "" Then
                RowToNode.setAttribute GetField(i, "name"), val
            End If
        Next
        RowToNode.setAttribute "cAutoCode", m_sPrjID
        RowToNode.setAttribute "cAutoName", m_sPlanID
    ElseIf m_iFlag = 3 Then
        RowToNode.setAttribute "iid", ocxCell.GetCellString(1, Row, 0)
    End If
End Function

'xml帮助方法
Private Sub MakeHead()
    Dim root As IXMLDOMElement
    Dim count As Integer
    Dim i As Integer
    
    
    Set m_objRef = New Collection
    Set root = m_objAid.objSelectRootTag(m_objHead)
    count = m_objAid.iNodeCount(root)
    m_objRef.Add "fiid", "iid"
    ocxCell.SetCols count + 1, 0
   '第一列宽度为0
    ocxCell.SetColHidden 1, 1
    
    For i = 2 To count
        ocxCell.SetColWidth 0, 250, i, 0
        ocxCell.SetCellString i, 0, 0, mID(root.childNodes(i - 1).nodename, 2)
        '产生名称对照
        m_objRef.Add root.childNodes(i - 1).nodename, m_objAid.GetAttributeVal("name", root.childNodes(i - 1))
        ocxCell.SetCellAlign i, 0, 0, 36
    Next
End Sub

Private Sub MakeRow()
    Dim root As IXMLDOMElement
    Dim Node As IXMLDOMElement
    Dim mp As IXMLDOMNamedNodeMap
    Dim attr As IXMLDOMAttribute
    Dim i As Integer, j As Integer
    Dim tp As String
    
    i = 1
    Set root = m_objAid.objSelectRootTag(m_objContent)
    '清空以前的数据
    ocxCell.SetRows 1, 0
    If GetHead("sum") <> "" Then
        ocxCell.SetRows m_objAid.iNodeCount(root) + 2, 0
    Else
        ocxCell.SetRows m_objAid.iNodeCount(root) + 1, 0
    End If
    
    For Each Node In root.childNodes
        Set mp = Node.Attributes
        If mp.length > 0 Then
            For Each attr In mp
                On Error Resume Next
                j = GetFieldIndex(m_objRef.Item(attr.nodename))
                If Err.Number = 0 Then
                    If j <> -1 Then
                        SetContent j, i, attr.nodeValue
                        
                        '设置表格数据,改变xml内容的同时改变表格数据
                        tp = GetField(j, "type")
                        Select Case tp
                            Case "数字"
                                ocxCell.SetCellDouble j, i, 0, attr.nodeValue
                            Case "日期"
                                ocxCell.SetCellDateStyle j, i, 0, 0
                                ocxCell.SetCellString j, i, 0, attr.nodeValue
                            Case "逻辑"
                                ocxCell.SetDroplistCell j, i, 0, "是" & Chr(10) & "否" & Chr(10), 0
                                If attr.nodeValue <> "0" Then
                                    ocxCell.SetCellString j, i, 0, "是"
                                    Node.setAttribute GetField(j, "name"), "1"
                                Else
                                    ocxCell.SetCellString j, i, 0, "否"
                                End If
                            Case "文本"
                                ocxCell.SetCellString j, i, 0, attr.nodeValue
                        End Select
                        ocxCell.SetCellAlign j, i, 0, 34
                    End If
                End If
            Next
        End If
        i = i + 1
    Next
End Sub

Private Sub MakeSum()
    Dim sumname As String
    Dim Node As IXMLDOMElement

    If ocxCell.GetRows(0) > 1 Then
        sumname = GetHead("sum")
        If sumname <> "" Then
            ocxCell.SetCellString 0, ocxCell.GetRows(0) - 1, 0, "合计"
            ocxCell.SetCellAlign GetFieldIndex(m_objRef.Item(sumname)), ocxCell.GetRows(0) - 1, 0, 34
        End If
    End If
End Sub

'控制不同模式菜单的可见性
Private Sub SwitchState(smode As String)
    If smode = "1" Then '录入
        tlbTool.Buttons("add").Visible = False
        tlbTool.Buttons("edit").Visible = False
        tlbTool.Buttons("delete").Visible = False
        tlbTool.Buttons("save").Visible = False
        tlbTool.Buttons("cancel").Visible = False
        tlbTool.Buttons("sep").Visible = False
    End If
End Sub

Private Sub SaveData()
    Dim root As IXMLDOMElement
    Dim sRow As Long, eRow As Long, sCol As Long, eCol As Long
    Dim AddOn As New U8BudgetMgr.clsAddOnImp
    Dim rtn As DOMDocument
    Dim i As Integer
    Dim doc As DOMDocument
    Dim Node As IXMLDOMElement
    Dim sumname As String
    
    If m_iFlag = 0 Then
        Exit Sub
    End If
    
    '获取合计
    sumname = GetHead("sum", m_objAid.objSelectRootTag(m_objHead))
    If sumname <> "" And ocxCell.GetRows(0) > 1 Then
        sumname = m_objParent.sSaveRow(m_iParentRow, ocxCell.GetCellString(GetFieldIndex(m_objRef.Item(sumname)), ocxCell.GetRows(0) - 1, 0))
        If sumname <> "" Then
            iShowMsg sumname
            Exit Sub
        End If
    End If
    
    If m_iFlag = 1 Then '如果是增加
       m_objContent.documentElement.setAttribute "proc", "insert"
    Else    '如果是修改
       m_objContent.documentElement.setAttribute "proc", "update"
    End If
    
    Set root = m_objAid.objSelectRootTag(m_objContent)
    root.setAttribute "table", GetHead("table")
    
    For Each Node In root.childNodes
        If m_objAid.GetAttributeVal("changed", Node) <> "" Then
            Node.setAttribute "cAutoCode", m_sPrjID
            Node.setAttribute "cAutoName", m_sPlanID
        End If
    Next
    
    AddOn.Transact m_objContent, doc, zjLogInfo
    If m_objAid.iSuccess(doc) <> 0 Then
        frmExportInfo.SetInfo doc.xml
        frmExportInfo.Show vbModal
        Exit Sub
    End If
    
    m_iFlag = 0
    SetButtonState
    Set m_objChanged = New Collection