项目定义窗体.frm

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

        Exit Sub
    End If
    
    '修改图标
    If m_sCurUpdate = "income" Or m_sCurUpdate = "expend" Or Len(m_sCurUpdate) = 3 Then
        treNode.Nodes(m_sCurUpdate).Image = "folder"
    Else
        treNode.Nodes(m_sCurUpdate).Image = "file"
    End If
    
    tmp = Node.key
    
    If tmp = "income" Then  '如果选中的是来源项目节点
        ClearPrjInfo
        cboPrjClass.ListIndex = 1
        tlbTool.Buttons("append").Enabled = False
        tlbTool.Buttons("edit").Enabled = False
        tlbTool.Buttons("delete").Enabled = False
        lbUsed.Visible = False
        Node.Image = "foldersel"
        m_sCurUpdate = Node.key
        Exit Sub
    ElseIf tmp = "expend" Then  '支出项目节点
        ClearPrjInfo
        tlbTool.Buttons("append").Enabled = False
        tlbTool.Buttons("edit").Enabled = False
        tlbTool.Buttons("delete").Enabled = False
        lbUsed.Visible = False
        Node.Image = "foldersel"
        m_sCurUpdate = Node.key
        Exit Sub
    End If
    
    Set str = m_objPrjInfo.Item(tmp)
    
    '判断是否已经使用
    If str.used(g_sDataSourceName) Then
        tlbTool.Buttons("delete").Enabled = False
        lbUsed.Visible = True
    Else
        tlbTool.Buttons("delete").Enabled = True
        lbUsed.Visible = False
    End If
    tlbTool.Buttons("edit").Enabled = True
    
    If Not (str.ParentCode = "") Then   '如果是第二级项目
        lbParentCode = str.ParentCode
        lbParentName = str.parentName
        tlbTool.Buttons("append").Enabled = True
        Node.Image = "filesel"
    Else    '第一级项目
        lbParentCode = ""
        lbParentName = IIf(str.PrjClass = 0, "支出类项目", "来源类项目")
        tlbTool.Buttons("append").Enabled = False
        Node.Image = "foldersel"
    End If
        
    cboPrjClass.ListIndex = str.PrjClass
    txtPrjCode.Text = str.ParentCode & str.code
    txtPrjName.Text = str.Name
    txtMemo.Text = str.Memo
    
    '保存当前选中的节点
    m_sCurUpdate = Node.key
End Sub

'载入项目定义结构树
Private Sub loadPrjTree()
    Dim con As ADODB.Connection
    Dim rs As New ADODB.Recordset   '一级项目数据
    Dim sql As String
    Dim errmsg As String

    On Error GoTo last
    
    '加入两个固定项目
    treNode.Nodes.Add , , "expend", "支出类项目"
    treNode.Nodes.Item("expend").Image = "folder"
    treNode.Nodes.Add , , "income", "来源类项目"
    treNode.Nodes.Item("income").Image = "folder"
    
    txtPrjCode.MaxLength = 4
    errmsg = "打开数据库出错!"
    Set con = m_objAid.objOpenDB(g_sDataSourceName)
    
    errmsg = "查询表fd_projdef出错,可能表不存在!"
    sql = "SELECT fd_projdef.iid, fd_projdef.sprjcode, fd_projdef.sprjname, fd_projdef.bprjclass,fd_projdef.iparentid ,scd.sprjcode AS sparentcode, scd.sprjname AS sparentname,fd_projdef.smemo FROM fd_projdef LEFT OUTER JOIN  fd_projdef scd ON scd.iid = fd_projdef.iparentid "
    
    '将节点加入
    Set rs = con.Execute(sql)
    While Not rs.EOF
        AppendRS rs
        rs.MoveNext
    Wend
    Set con = Nothing

    '如果有项目,选中来源固定项目
    SelectNode (1)
    SetButtonState
    Exit Sub
last:
    If Trim(errmsg) = "" Then
        PrintErr Error
    Else
        PrintErr errmsg
    End If
    Err.clear
End Sub

'初始化
Public Sub InitState()
    SetPassive
    m_iSavFlag = 0
    cboPrjClass.ListIndex = 0
    treNode.LabelEdit = tvwManual
End Sub

'刷新操作
Private Sub Reload()
    Finalize
    loadPrjTree
End Sub

'保存修改或增加的数据
Private Sub SaveData()
    Dim con As ADODB.Connection
    Dim rs As New ADODB.Recordset
    Dim sql As String
    Dim errmsg As String
    
    On Error GoTo last
    
    '检查项目所需信息的完整性
    If Not bCheckPrjInfo Then
       Exit Sub
    End If
    
    sql = ""
    If m_iSavFlag = 1 Then    '如果是增加节点
        errmsg = "打开数据库时出错!"
        Set con = m_objAid.objOpenDB(g_sDataSourceName)
        
        con.BeginTrans
        errmsg = "添加项目信息时出错!"
        
        '插入数据
        sql = "insert into fd_projdef(sprjcode,sprjname,iparentid,bprjclass,smemo,sprjaddon) values('" & m_objTmp.code & "','" & m_objTmp.Name & "','" & m_objTmp.PID & "','" & m_objTmp.PrjClass & "','" & m_objTmp.Memo & "',null)"
        con.Execute sql
        
        '获取记录id
        sql = "select max(iid) from fd_projdef"
        Set rs = con.Execute(sql)
        m_objTmp.id = CInt(rs(0))
        con.CommitTrans
        
        Set con = Nothing
    Else
        errmsg = "打开数据库时出错!"
        Set con = m_objAid.objOpenDB(g_sDataSourceName)
        errmsg = "更新项目信息出错!"
        
        con.BeginTrans
        sql = "update fd_projdef set sprjcode= '" & m_objTmp.code & "',sprjname='" & m_objTmp.Name & "',iparentid='" & m_objTmp.PID & "',bprjclass = '" & m_objTmp.PrjClass & "',smemo='" & m_objTmp.Memo & "' where iid = '" & m_objTmp.id & "'"
        con.Execute sql
        
        '如果含有子项目,更改子节点
        If treNode.Nodes(m_sCurUpdate).children > 0 Then
            sql = "update fd_projdef set bprjclass='" & m_objTmp.PrjClass & "' where iparentid = '" & m_objTmp.id & "'"
            con.Execute sql
        End If
        con.CommitTrans
        
        Set con = Nothing
    End If
    
    m_iSavFlag = 0
    Reload
    
    SelectNode (m_objTmp.key)
    Set m_objTmp = Nothing
    SetPassive
    Exit Sub
last:
    If Trim(errmsg) = "" Then
        PrintErr Error
    Else
        PrintErr errmsg
    End If
    Err.clear
End Sub

'进入修改状态
Private Sub SetChange()
    '如果当前没有选中项目退出
    If (treNode.SelectedItem Is Nothing) Then
        iShowMsg "请先选择要修改的项目节点"
        Exit Sub
    End If

    Set m_objTmp = m_objPrjInfo(m_sCurUpdate)
    SetEdit
    m_iSavFlag = 2
    
    '如果是二级项目,不允许它改变项目类型
    If m_objTmp.PID <> 0 Then
        cboPrjClass.Enabled = False
    Else
        If treNode.SelectedItem.children <> 0 Then
            txtPrjCode.MaxLength = 2
        Else
            txtPrjCode.MaxLength = 4
        End If
    End If
    SetButtonState
End Sub

'显示附表
Private Sub AddOn()
    Dim tmp As U8BudgetMgr.clsPrjData
    
    Set tmp = m_objPrjInfo.Item(treNode.SelectedItem.key)
    frmAddOnSet.prjid = tmp.id
    frmAddOnSet.Show vbModal
End Sub

'删除节点
Private Sub DeleteData()
    Dim count As Integer
    Dim tmp As MsComctlLib.Node
    Dim con As ADODB.Connection
    Dim sql As String
    Dim nod As clsPrjData
    Dim chd As MsComctlLib.Node
    Dim errmsg As String
    
    '没有选中节点,退出
    If treNode.SelectedItem Is Nothing Then
        iShowMsg "请先选择要删除的项目节点"
        Exit Sub
    End If
    
    '提示删除
    If iShowMsg("确定要删除吗?", vbYesNo) = vbNo Then
        Exit Sub
    End If
    
    '删除父项目和子项目
    On Error GoTo last
    errmsg = "打开数据库出错,不能进行删除操作!"
    Set con = m_objAid.objOpenDB(g_sDataSourceName)
    Set tmp = treNode.SelectedItem
    
    errmsg = "删除项目时出错!"
    '删除子节点
    If tmp.children > 0 Then
        Set chd = tmp.child
        For count = 1 To tmp.children
            Set nod = m_objPrjInfo.Item(chd.key)
            m_objPrjInfo.Remove chd.key
            con.Execute "delete from fd_projdef where iid = '" & nod.id & "'"
            Set chd = chd.Next
            Set nod = Nothing
        Next
    End If
    
    '删除父节点
    Set nod = m_objPrjInfo.Item(tmp.key)
    con.Execute "delete from fd_projdef where iid = '" & nod.id & "'"
    m_objPrjInfo.Remove tmp.key
    treNode.Nodes.Remove tmp.key
    
    '如果树视图空,清除项目信息
    If treNode.Nodes.count = 0 Then
        ClearPrjInfo
    End If
    
    '选中新节点
    If nod.ParentCode <> "" Then
        SelectNode (nod.ParentKey)
    ElseIf nod.PrjClass = 0 Then
        SelectNode ("expend")
    Else
        SelectNode ("income")
    End If
    
    Set nod = Nothing
    SetButtonState
    Exit Sub
last:
    If Trim(errmsg) = "" Then
        PrintErr Error
    Else
        PrintErr errmsg
    End If
    Err.clear
End Sub

'取消改变
Private Sub Cancel()
    If iCheck = vbCancel Then
        Exit Sub
    End If
End Sub

'使能项目信息输入控件
Private Sub SetEdit()
    cboPrjClass.Enabled = True
    cboPrjClass.SetFocus
    txtPrjCode.Enabled = True
    txtPrjName.Enabled = True
    txtMemo.Enabled = True
End Sub

'禁止使用项目信息输入控件
Private Sub SetPassive()
    cboPrjClass.Enabled = False
    txtPrjCode.Enabled = False
    txtPrjName.Enabled = False
    txtMemo.Enabled = False
End Sub

'清除当前的项目信息
Private Sub ClearPrjInfo()
    txtPrjCode.Text = ""
    txtPrjName.Text = ""
    lbParentName = ""
    lbParentCode = ""
    txtMemo.Text = ""
    cboPrjClass.ListIndex = 0
End Sub

'改动前提示
Private Function iCheck(Optional flag As Boolean = True) As Integer
    Dim sparam As String
    iCheck = 0
    If m_iSavFlag = 0 Then
        Exit Function
    ElseIf m_iSavFlag <> 0 And Not flag Then
        iShowMsg "请您先完成当前操作!"
        iCheck = vbCancel
        Exit Function
    ElseIf m_iSavFlag = 1 Then
        sparam = "要保存增加的项目吗?"
    Else
        sparam = "要保存项目的修改吗?"
    End If
    iCheck = iShowMsg(sparam, vbYesNoCancel)
    If iCheck = vbNo Then
        '清除数据
        m_iSavFlag = 0
        Set m_objTmp = Nothing
        SetPassive
        SelectNode (m_sCurUpdate)
        SetButtonState
    ElseIf iCheck = vbYes Then
        SaveData
    Else
    End If
End Function

'提示出错信息
Private Function PrintErr(str As String) As Boolean
    If str <> "" Then
        iShowMsg str
    End If
    str = ""
End Function

'检查项目信息完整性
Private Function bCheckPrjInfo() As Boolean
    Dim str As String
    Dim pa As U8BudgetMgr.clsPrjData
    
    bCheckPrjInfo = False
    
    '检查项目编号
    str = Trim(txtPrjCode.Text)
    If str = "" Then
        iShowMsg "项目编号不能为空!"