资金使用计划.frm

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

                iShowMsg "输入日期不得大于截至日期!"
                Exit Sub
            End If
        Else
            tp = GetField(m_iCol, "len")
            If tp <> "" Then
                If Len(Text) > CInt(tp) Then
                    iShowMsg "注释不能超过" & tp & "个字!"
                    Exit Sub
                End If
            End If
        End If
        approve = 1
        SetContent m_iCol, m_iRow, Text
        If GetField(m_iCol, "type") = "money" And strOrigin <> Text Then
            GetSum
        End If
    End If
End Sub

Private Sub ocxCell_MouseDClick(ByVal Col As Long, ByVal Row As Long)
    Dim rtn As Double
    Dim mode As String
    
    On Error GoTo last
    
    '只能在保存后才能录入附表
    If m_objContent Is Nothing Then Exit Sub
    
    If GetField(m_iCol, "fieldname") = "scaptionc" And GetContent(m_iCol, m_iRow, "islid") <> "-1" Then
        If GetHead("smode") = "0" And GetHead("operation") <> "" Then   '如果处于录入状态,并且进行修改或录入才能修改附表数据
            frmAddOn.iMode = 0
            frmAddOn.SetParent Me, m_iRow
            frmAddOn.Show vbModal
        Else    '其他的包括申报模式都可以进行查看
            frmAddOn.iMode = 1
            frmAddOn.SetParent Me, m_iRow
            frmAddOn.Show vbModal
        End If
    End If
    Exit Sub
last:
    Err.clear
End Sub

Private Sub ocxCell_MouseLClick(ByVal Col As Long, ByVal Row As Long, ByVal updn As Long)
    Dim obj As U8BudgetMgr.clsPlanImp
    
    On Error Resume Next
    ocxCell.ReadOnly = 1
    
    If m_objContent Is Nothing Or Row < 2 Then Exit Sub
        
    If GetField(m_iCol, "type") = "datetime" And ocxCell.GetCellDouble(m_iCol, m_iRow, 0) <> 0 Then
        SetContent m_iCol, m_iRow, CDate(ocxCell.GetCellDouble(m_iCol, m_iRow, 0))
    End If

    If GetHead("operation") = "" Then
        ocxCell.ReadOnly = 1
    Else
        HideRef
            
'        txtsUnitname_LostFocus
'        If GetHead("accunit_id") = "" Then
'            ishowmsg "必须指定正确的单位!"
'            txtsUnitname.SetFocus
'            Exit Sub
'        End If
'
'        txtBudget_LostFocus
'        If GetHead("ibudgetid") = "" Then
'            ishowmsg "必须指定正确的预算!"
'            txtBudget.SetFocus
'            Exit Sub
'        End If
        
        If Trim(txtdStart.Text) = "" Then
            iShowMsg "必须先填写起始日期!"
            txtdStart.SetFocus
            Exit Sub
        End If
        
        If Trim(txtdEnd.Text) = "" Then
            iShowMsg "必须先填写截至日期!"
            txtdEnd.SetFocus
            Exit Sub
        End If
        
        '测试行和列
        If GetField(Col, "readonly") = "1" Or GetContent(Col, Row, "readonly") = "1" _
            Or Row = 1 Or (GetContent(Col, Row, "sum") = "1" And GetField(Col, "fieldname") <> "sremark") _
            Or (GetContent(Col, Row, "innersum") = "1" And GetField(Col, "fieldname") <> "sremark") Then
            ocxCell.ReadOnly = 1
        Else
            ocxCell.ReadOnly = 0
            '如果已经填写了附表,不能在修改数据了,只能修改附表数据
            Set obj = m_objMgr
            If GetHead("smode") = "0" And obj.bPrjInUsed(GetContent(1, m_iRow, "islid"), GetHead("iid"), GetHead("addon")) Then
                ocxCell.ReadOnly = 1
            End If
        End If
    End If
    '记忆
    m_iRow = Row
    m_iCol = Col
End Sub

'主表操作
Public Sub SetHead(sName As String, sValue As String, Optional Node As IXMLDOMElement = Nothing)
    If Node Is Nothing Then
        If m_objHead.xml = "" Then
            m_objHead.loadXML "<head/>"
        End If
        Set Node = m_objHead.documentElement
    End If
    
    Node.setAttribute sName, sValue
    If (sName = "smode") Then
        If sValue = "0" Then
            m_sWhere = " where fd_budgethead.btype='1'"
            Node.setAttribute "template", "plan_declare"
            Set m_objMgr = New U8BudgetMgr.clsPlanImp
        ElseIf sValue = "1" Then
            m_sWhere = " where fd_budgethead.btype='1'"
            Node.setAttribute "template", "plan_approve"
            Set m_objMgr = New U8BudgetMgr.clsPlanImp
        Else
            m_sWhere = " where fd_budgethead.btype='1' and fd_budgethead.dapprove is not null"
            Node.setAttribute "template", "plan_analys"
            Set m_objMgr = New U8BudgetMgr.clsAnalysSingleImp
        End If
        '表头
        m_objMgr.Init zjLogInfo
        m_objMgr.GetTableHead m_objHead, m_objTable, m_objError
        If PrintError(m_objError) Then Exit Sub
        '获取记录集合
        
        m_objMgr.GetIDSerial m_arrReportID, objWrapWhere(m_sWhere), m_objError
        If PrintError(m_objError) Then Exit Sub
                
    End If
End Sub

Public Function GetHead(sName As String, Optional Node As IXMLDOMElement = Nothing) As String
    Dim tmp
    If Node Is Nothing Then
        Set Node = m_objHead.documentElement
    End If
    GetHead = m_objAid.GetAttributeVal(sName, Node)
'    If sName = "sname" And GetHead = "" Then
'        GetHead = "资金使用计划申报表(##)"
'    End If
End Function

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

'子表操作
Public Sub SetContent(ByVal Col As Integer, ByVal Row As Integer, sValue As String, Optional attr As String = "")
    Dim child As IXMLDOMElement
    Dim tmp As String
    Dim R As Integer
    Dim tp As String
    
    If attr = "" Then
        tmp = GetField(Col, "fieldname")
    Else
        tmp = attr
        Col = GetFieldIndex(attr)
    End If
    
    Set child = m_objContent.documentElement.childNodes.Item(Row - 2)
    tp = GetField(Col, "type")
    If tp = "money" And sValue = "0" Then
        sValue = ""
    End If
    If sValue = "" Then
        RemoveHead tmp, child
    Else
        child.setAttribute tmp, sValue
    End If
    
    '如果数字字段为0,保存为空
    
    'If GetHead("smode") <> "2" And GetContent(-1, Row, "sum") <> "1" And tp = "money" And sValue = "0" Then
    If tp = "int" Then
        ocxCell.SetCellString Col, Row, 0, m_objMgr.GetCur("cur" & sValue)
    Else
        ocxCell.SetCellString Col, Row, 0, sValue
    End If
End Sub
'
Public Function GetContent(ByVal Col As Integer, ByVal Row As Integer, Optional str As String) As String
    Dim child As IXMLDOMElement
    Dim tmp
    Dim tp As String

    If str = "" Then
        tmp = GetField(Col, "fieldname")
    Else
        tmp = str
    End If
    
    Set child = m_objContent.documentElement.childNodes.Item(Row - 2)
    GetContent = m_objAid.GetAttributeVal(CStr(tmp), child)
    
    '如果是数字信息,而且内容为空的话,设置为0,计算时用
    tp = GetField(Col, "type")
    If (tp = "money" Or Col = -1) And GetContent = "" Then
        GetContent = "0"
    ElseIf tp = "int" Then
        GetContent = m_objMgr.GetCur("cur" & GetContent)
    ElseIf tp = "datetime" And GetContent <> "" Then    '校正日期
        GetContent = m_objAid.sCheckDate(GetContent)
    End If
End Function

Private Function GetField(ByVal Col, ByVal sValue As String) As String
    Dim child As IXMLDOMElement
    
    If IsNumeric(Col) Then
        Set child = m_objTable.documentElement.childNodes.Item(Col - 1)
    Else
        Set child = m_objTable.documentElement.selectSingleNode(Col)
    End If
    
    GetField = m_objAid.GetAttributeVal(sValue, child)
End Function

Private Function GetFieldIndex(ByVal sValue As String) As Integer
    Dim child As IXMLDOMElement
    
    GetFieldIndex = -1
    Set child = m_objTable.documentElement.selectSingleNode(sValue)
    GetFieldIndex = CInt(child.getAttribute("index"))
End Function

'dom 数据库 cell
Private Sub DomToTable()
    Dim mode As String
    
    mode = GetHead("smode")
    If GetHead("operation") = "add" Then    '新建
        MakeTitle
        MakeHead
        MakeRow
        MergeRow
    ElseIf m_iPos = 0 Then  '没有数据,显示空表
            m_objHead.loadXML "<head smode='" & GetHead("smode") & "' btype='1'/>"
            ClearReportInfo
'            ocxCell.ResetContent
            Set m_objContent = Nothing
            SetTableState
            SetPassive
            MakeHead
    Else    '显示已有的数据
        If m_objHead.documentElement.Attributes.length > 3 Then
            m_objHead.loadXML "<head smode='" & mode & "' btype='1'/>"
        End If
        SetHead "book", CStr(m_iBook)
        SetHead "iid", m_arrReportID(m_iPos)
        m_objMgr.GetReport m_objHead, m_objContent, m_objError
        If PrintError(m_objError) Then Exit Sub
        SetPassive
        MakeTitle
        MakeHead
        MakeRow
        MergeRow
''        If GetHead("smode") = "2" Then
'        GetSum "mapprove"
'        GetSum "mused"
''        End If
        
    End If
    SetPageInfo
End Sub

Private Sub TableToDB()
    Dim proc As String
    
    proc = GetHead("operation")
    If GetHead("smode") = "0" And (proc = "desert" Or proc = "confirm") Then
        m_objMgr.SetReport m_objHead, Nothing, m_objError
    Else
        m_objMgr.SetReport m_objHead, m_objContent, m_objError
    End If
    If PrintError(m_objError) Then Exit Sub
End Sub

Private Sub MakeHead()
    Dim i As Integer
    Dim Col As Integer
    Dim tmp
    Dim left As Integer
    Dim right As Integer
    Dim cmergeid As String
    
    
    Col = m_objTable.documentElement.childNodes.length
    ocxCell.SetCols Col + 1, 0
    left = 0
    right = 0
    i = 1
    While i <= Col
        tmp = GetField(i, "mergeid")
        If tmp <> "" And tmp <> cmergeid Then   '定义起始位置
            cmergeid = tmp
            right = i
            left = i
        ElseIf tmp = "" Then    '合并表头
            ocxCell.MergeCells left, 1, right, 1
            right = right + 1
            left = right
        Else
            right = right + 1
        End If
        
        ocxCell.SetColWidth 0, CInt(GetField(i, "width")), i, 0
        ocxCell.SetCellString i, 1, 0, GetField(i, "caption")
        ocxCell.SetCellAlign i, 1, 0, 36
        ocxCell.SetCellBackColor i, 1, 0, ocxCell.FindColorIndex(RGB(255, 128, 255), 1)
        ocxCell.SetCellFont i, 1, 0, ocxCell.FindFontIndex("宋体", 1)
        ocxCell.SetCellFontSize i, 1, 0, 9
        i = i + 1
    Wend
    ocxCell.SetFixedCol 1, 2
End Sub

Private Sub MakeRow()
    Dim root As IXMLDOMElement
    Dim Node As IXMLDOMElement
    Dim Col As Integer
    Dim Row As Integer
    Dim i As Integer, j As Integer
    Dim tmp, tmp1
    Dim left As Integer, right As Integer, top As Integer, bottom As Integer
    Dim cmergeid As String, rmergeid As String
    
    '获取行列数,设定行数
    Col = m_objTable.documentElement.childNodes.length
    Row = m_objContent.documentElement.childNodes.length
    ocxCell.SetRows Row + 2, 0
    cmergeid = "1"
    Set root = m_objContent.documentElement
    j = 2
    For Each Node In root.childNodes
        If GetHead("mergeallcol", Node) = "1" Then  '整行合并
            ocxCell.MergeCells 1, j, Col + 1, j
            ocxCell.SetCellAlign 1, j, 0, 33
            ocxCell.SetCellString 1, j, 0, GetHead(GetField(1, "fieldname"), Node)
            ocxCell.SetCellBackColor 1, j, 0, ocxCell.FindColorIndex(RGB(128, 255, 128), 1)
            ocxCell.SetCellFont 1, j, 0, ocxCell.FindFontIndex("宋体", 1)
            ocxCell.SetCellFontSize 1, j, 0, 9
        Else    '
            i = 1
            cmergeid = ""
            While i <= Col
   
                '设定单元格式
                tmp = GetField(i, "type")
                If (tmp = "money") Then    '数字
                    ocxCell.SetCellString i, j, 0, GetHead(GetField(i, "fieldname"), Node)
                ElseIf (tmp = "int") Then '下拉框
'                    If GetHead("mergeid", node) = "" Then
'                        ocxCell.SetDroplistCell i, j, 0, m_objMgr.GetCur(), 0
'                    End If
                    tmp = GetHead(GetField(i, "fieldname"), Node)
                    tmp1 = m_objMgr.GetCur("cur" & tmp)
                    ocxCell.SetCellString i, j, 0, tmp1
                ElseIf (tmp = "datetime") Then  '日期格式
'                    ocxCell.SetNormalCell i, j, 0
                    ocxCell.SetCellString i, j, 0, m_objAid.sCheckDate(GetHead(GetField(i, "fieldname"), Node))
                Else    '普通处理
                    ocxCell.SetCellString i, j, 0, GetHead(GetField(i, "fieldname"), Node)
                End If
                
                ocxCell.SetCellAlign i, j, 0, 32 + CInt(GetField(i, "align"))
                If GetHead("readonly", Node) = "1" Then
                    ocxCell.SetCellBackColor i, j, 0, ocxCell.FindColorIndex(RGB(128, 255, 128), 1)
                ElseIf GetHead("sum", Node) = "1" Then
                    ocxCell.SetCellBackColor i, j, 0, ocxCell.FindColorIndex(RGB(0, 128, 255), 1)
                ElseIf GetHead("innersum", Node) = "1" And i <> 1 Then  '小计行颜色
                    ocxCell.SetCellBackColor i, j, 0, ocxCell.FindColorIndex(RGB(255, 255, 0), 1)
                End If
                ocxCell.SetCellFont i, j, 0, ocxCell.FindFontIndex("宋体", 1)
                ocxCell.SetCellFontSize i, j, 0, 9
                i = i + 1
            Wend
        End If
        j = j + 1
    Next
    ocxCell.SetFixedRow 1, 1
End Sub

Private Sub MakeTitle()
    Dim Node As IXMLDOMElement
    Set Node = m_objHead.documentElement
    txtsUnitname.Text = GetHead("sunitname")
    txtdStart.Text = m_objAid.sCheckDate(GetHead("dstart"))
    txtdEnd.Text = m_objAid.sCheckDate(GetHead("dend"))
    txtdDeclare.Text = m_objAid.sCheckDate(GetHead("ddeclare"))
    txtdApprove.Text = m_objAid.sCheckDate(GetHead("dapprove"))
    txtBudget.Text = GetHead("sbudgetname")
    txtsName.Text = GetHead("sname")
    stbState.Panels("sbill").Text = "制单人: " & GetHead("sbill")