资金使用计划.frm

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

    SetEdit
    SetButtonState
End Sub

Private Sub Audit()
    SetHead "operation", "audit"
    SetHead "scheck", zjLogInfo.cUserName
    SetEdit
    SetButtonState
End Sub

Private Sub Append()
    '防止重入
    SetHead "operation", "append"
    SetHead "scheck", zjLogInfo.cUserName
    SetEdit
    SetButtonState
End Sub

Private Sub Query(Optional str As String, Optional pos As Integer = 0)
    If str = "" Then
        Return
    End If
    m_objMgr.GetIDSerial m_arrReportID, objWrapWhere(str), m_objError
    If PrintError(m_objError) Then Exit Sub
    If m_arrReportID.count > 0 Then
        If pos = 0 Or pos > m_arrReportID.count Then
            Go2 1
        Else
            Go2 pos
        End If
    Else
        Go2 0
        iShowMsg "目前没有相关记录!"
    End If
End Sub

Private Sub Confirm()
    SetHead "operation", "confirm"
    SetHead "sconfirm", zjLogInfo.cUserName
    SaveData
End Sub

Private Sub Desert()
    Dim Row As Integer
    Dim i As Integer
    
    If GetHead("smode") = "0" Then
        SetHead "operation", "desert"
        RemoveHead "sconfirm"
    Else
        Row = m_objContent.documentElement.childNodes.length + 1
        RemoveHead "scheck"
        RemoveHead "dapprove"
        SetHead "operation", "desert"
        For i = 2 To Row
            SetContent 1, i, "", "mapprove"
        Next
    End If
    SaveData
End Sub

Private Sub FillMe()
    If GetHead("scheck") <> GetHead("sbill") Then
        Dim Row As Integer
        Dim i As Integer
        
        Row = m_objContent.documentElement.childNodes.length + 1
        For i = 2 To Row
            SetContent -1, i, GetContent(-1, i, "mdeclare"), "mapprove"
        Next
    End If
    GetSum
End Sub

Private Sub RemovePrintPart()
    ocxCell.DeleteRow 1, 6, 0
    ocxCell.SetRows ocxCell.GetRows(0) - 2, 0
    ocxCell.SetFixedCol 1, 2
    ocxCell.SetFixedRow 1, 1
End Sub

Private Sub PrintMe()
    HeadToTable
    ocxCell.PrintPara 1, 0, 1, 1
    ocxCell.PrintSheet 1, 0
    RemovePrintPart
End Sub

Private Sub Preview()
    HeadToTable
    ocxCell.PrintPara 1, 0, 1, 1
    ocxCell.PrintPreview 1, 0
    RemovePrintPart
End Sub

Private Sub QueryIt()
    If GetHead("smode") = "2" Then
        frmBudgetQuery.ShowAnalys (True)
    End If
    frmBudgetQuery.ReportType "1"
    frmBudgetQuery.Show vbModal
    If frmBudgetQuery.where <> "" Then
        m_sWhere = frmBudgetQuery.where
        m_iBook = frmBudgetQuery.book
        Query m_sWhere, 1
    End If
End Sub

Private Sub Quit()
    Unload Me
End Sub

'报表求小计
Private Sub GetSum(Optional mode As String)
    Dim Cur As Integer
    Dim Row As Integer
    Dim i As Integer
    Dim j As Integer
    Dim keyword As String
    Dim income As Double, outcome As Double, sum As Double
    Dim inpos As Integer, outpos As Integer
    Dim oldcodeh As String, newcodeh As String
    
    Set m_objsum = New Collection
    Row = m_objContent.documentElement.childNodes.length
    Cur = CInt(m_objAid.GetAttributeVal("cur", m_objContent.documentElement))   '币种数目

    '来源总计
    i = Cur + 3
    If mode = "" Then
        mode = GetHead("smode")
    End If
    If mode = "1" Then
        mode = "mapprove"
    ElseIf mode = "0" Then
        mode = "mdeclare"
    End If
    
    oldcodeh = "-3"
    newcodeh = GetContent(1, i, "iflid")
    While newcodeh <> "-3"
        keyword = GetContent(1, i, "scurcode") & "1"
        '如果项目变更了,记录初试
        If newcodeh <> oldcodeh Then
            On Error Resume Next
            sum = CDbl(m_objsum.Item(keyword))
            If Err.Number <> 0 Then
                sum = 0
                Err.clear
            End If
        End If
        If GetContent(1, i, "islid") <> "-1" Then
            AddIt i, keyword, mode
        Else
            SetContent -1, i, CStr(CDbl(m_objsum.Item(keyword)) - sum), mode
            
        End If
        oldcodeh = newcodeh
        i = i + 1
        newcodeh = GetContent(1, i, "iflid")
    Wend
    inpos = i
    '支出总计
    i = i + Cur + 1
    oldcodeh = "-3"
    newcodeh = GetContent(1, i, "iflid")
    outpos = Row - 2 * Cur + 2
    While i < outpos
        keyword = GetContent(1, i, "scurcode") & "2"
        If newcodeh <> oldcodeh Then
            On Error Resume Next
            sum = CDbl(m_objsum.Item(keyword))
            If Err.Number <> 0 Then
                sum = 0
                Err.clear
            End If
        End If
        If GetContent(1, i, "islid") <> "-1" Then
            AddIt i, keyword, mode
        Else
            SetContent -1, i, CStr(CDbl(m_objsum.Item(keyword)) - sum), mode
        End If
        oldcodeh = newcodeh
        i = i + 1
        newcodeh = GetContent(1, i, "iflid")
    Wend
    '期末结存
    On Error Resume Next
    For i = 1 To Cur
        keyword = GetContent(1, i + 1, "scurcode")
        income = 0
        outcome = 0
        '计算来源
        On Error Resume Next
        income = CDbl(m_objsum.Item(keyword & "1"))
        If Err.Number <> 0 Then
            income = 0
            Err.clear
        End If
        SetContent -1, inpos, CStr(income), mode
        inpos = inpos + 1
        '计算支出
        outcome = CDbl(m_objsum.Item(keyword & "2"))
        If Err.Number <> 0 Then
            outcome = 0
            Err.clear
        End If
        SetContent -1, outpos, CStr(outcome), mode
        outpos = outpos + 1
        '计算合计
        If GetHead("smode") <> "2" Then
            SetContent -1, Row - Cur + i + 1, CStr(CDbl(GetContent(-1, i + 1, mode)) + income - outcome), mode
        End If
    Next
End Sub

Private Sub AddIt(Row As Integer, flag As String, mode As String)
    Dim mny As String
    Dim tmp As String
    
    mny = GetContent(-1, Row, mode)
    If mny = "" Then
        mny = "0"
    End If
    On Error Resume Next
    m_objsum.Item (flag)
    If Err.Number <> 0 Then
        m_objsum.Add mny, flag
    Else
        tmp = m_objsum.Item(flag)
        m_objsum.Remove flag
        m_objsum.Add CStr(CDbl(mny) + CDbl(tmp)), flag
    End If
End Sub

'填充币种
Private Sub FillCur()
    Dim Cur As New Collection
    Dim Row As Integer
    Dim i As Integer
    Dim codeh As String
    
    m_objMgr.GetCur GetHead("ibudgetid"), Cur
    Row = m_objContent.documentElement.childNodes.length + 1
    On Error Resume Next
    For i = 2 To Row
        codeh = GetContent(1, i, "iflid")
        If mID(codeh, 1, 1) <> "-" Then
            SetContent -1, i, Cur.Item(codeh), "scurcode"
        End If
    Next
End Sub

 '其他
 Private Function iCheck() As Integer
    Dim sparam As String
    iCheck = 0
    If GetHead("operation") = "" Then
        Exit Function
    ElseIf GetHead("operation") = "add" Then
        sparam = "要保存增加的项目吗?"
    Else
        sparam = "要保存项目的修改吗?"
    End If
    iCheck = iShowMsg(sparam, vbYesNoCancel)
    If iCheck = vbNo Then
        ManageAddon '删除附表数据
        SetHead "operation", ""
        DomToTable
    ElseIf iCheck = vbYes Then
        SaveData
    Else
        
    End If
End Function

Private Function bCheckTitle() As Boolean
    '检查时间格式
    Dim vTmp
        
    '非审批模式检查头部信息
    bCheckTitle = False
    If GetHead("smode") = "0" Then
        
        '编号不能为空
        txtsName = Trim(txtsName)
        If txtsName.Text = "" Then
            iShowMsg "编号不能为空!"
            txtsName.SetFocus
            Exit Function
        End If
        
        '检查单位名称写了没有
        txtsUnitname = Trim(txtsUnitname)
        vTmp = vCheckExist("unit", txtsUnitname)
        If IsNull(vTmp) Then
            iShowMsg "必须指定正确的单位!"
            txtsUnitname.SetFocus
            Exit Function
        Else
            SetHead "accunit_id", CStr(vTmp)
        End If
        
        '检查预算写了没有
        txtBudget = Trim(txtBudget)
        vTmp = vCheckExist("budget", txtBudget)
        If IsNull(vTmp) Then
            iShowMsg "必须指定正确的预算!"
            txtBudget.SetFocus
            Exit Function
        Else
            SetHead "ibudgetid", CStr(vTmp)
        End If
        
        '检查开始时间填了吗
        txtdStart = m_objAid.sCheckDate(txtdStart)
        If Trim(txtdStart.Text) = "" Then
            iShowMsg "请填好起始时间!"
            txtdStart.SetFocus
            Exit Function
        End If
        
        '检查截至时间填了吗
        txtdEnd = m_objAid.sCheckDate(txtdEnd)
        If Trim(txtdEnd.Text) = "" Then
            iShowMsg "请填好截至时间!"
            txtdEnd.SetFocus
            Exit Function
        End If
        
        '检查开始时间填了吗
        txtdDeclare = m_objAid.sCheckDate(txtdDeclare)
        If Trim(txtdDeclare.Text) = "" Then
            iShowMsg "请填好申报时间!"
            txtdDeclare.SetFocus
            Exit Function
        End If
        
        '申报日期大于启用日期
        If m_objAid.iDateDiff(txtdDeclare, CStr(ZjAccInfo.zjStartdate)) > 0 Then
            iShowMsg "申报日期必须大于启用日期!"
            txtdDeclare.SetFocus
            Exit Function
        End If
        
        '申报时间小于等于登陆时间
        If m_objAid.iDateDiff(zjLogInfo.curDate, txtdDeclare) > 0 Then
            iShowMsg "申报日期必须小于等于登陆日期!"
            txtdDeclare.SetFocus
            Exit Function
        End If
        
        '起始日期必须大于申报日期
        If m_objAid.iDateDiff(txtdStart, txtdDeclare) >= 0 Then
            iShowMsg "起始日期必须大于申报日期!"
            txtdStart.SetFocus
            Exit Function
        End If
        
        '起始日期必须小于截至日期
        If m_objAid.iDateDiff(txtdStart, txtdEnd) <= 0 Then
            iShowMsg "输入的截至日期必须大于起始日期!"
            txtdEnd.SetFocus
            Exit Function
        End If
    Else
        txtdApprove = m_objAid.sCheckDate(txtdApprove)
        If Trim(txtdApprove.Text) = "" Then
            iShowMsg "请填写审批日期!"
            txtdApprove.SetFocus
            Exit Function
        End If
        
        If m_objAid.iDateDiff(txtdEnd, CStr(ZjAccInfo.zjStartdate)) > 0 Then
            iShowMsg "审批日期必须大于等于启用日期!"
            txtdApprove.SetFocus
            Exit Function
        End If
        
        '审批日期小于等于登陆日期
        If m_objAid.iDateDiff(zjLogInfo.curDate, txtdApprove) > 0 Then
            iShowMsg "审批日期必须小于等于登陆日期!"
            txtdApprove.SetFocus
            Exit Function
        End If
        
        '审批日期大于等于申报日期
        If m_objAid.iDateDiff(txtdApprove, txtdDeclare) > 0 Then
            iShowMsg "审批日期必须大于申报日期!"
            txtdApprove.SetFocus
            Exit Function
        End If
        
        '起始日期必须大于审批日期
        If m_objAid.iDateDiff(txtdStart, txtdApprove) >= 0 Then
            iShowMsg "起始日期必须大于审批日期!"
            txtdApprove.SetFocus
            Exit Function
        End If
    End If
    bCheckTitle = True
End Function

'插入和删除统一处理,因为取消操作将所有新加附表数据删除,所以有必要在更新操作时区分以前和新加的数据
Private Sub ManageAddon(Optional flag As