项目定义窗体.frm

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

        txtPrjCode.SetFocus
        Exit Function
    End If
    
    '项目名称
    If Trim(txtPrjName.Text) = "" Then
        iShowMsg "项目名称不能为空!"
        txtPrjName.SetFocus
        Exit Function
    End If
    
    If Not bCheckEdit(1) Then
        Exit Function
    End If
    
    If Not bCheckEdit(2) Then
        Exit Function
    End If
        
    If Not bCheckEdit(3) Then
        Exit Function
    End If
    
    If Len(str) Mod 2 <> 0 Then '如果项目编号不是两位或4位,用0补全
        str = "0" & str
        txtPrjCode.Text = str
        txtPrjCode.SetFocus
    End If
    
    '如果是二级项目,首先检查其父编号存在与否
    If Len(str) = 4 Then
        On Error Resume Next
        Set pa = m_objPrjInfo.Item("k" & mID(str, 1, 2))
        If Err.Number <> 0 Then
            iShowMsg "指定的父编号不存在!"
            Err.clear
            Exit Function
        Else
            m_objTmp.ParentCode = pa.code
            m_objTmp.parentName = pa.Name
            m_objTmp.PID = pa.id
            m_objTmp.PrjClass = pa.PrjClass
        End If
        m_objTmp.code = mID(str, 3, 2)
    Else
            m_objTmp.ParentCode = ""
            m_objTmp.parentName = ""
            m_objTmp.PID = 0
            m_objTmp.code = str
    End If
    
    '检查编号是否已经存在了
    On Error Resume Next
    m_objPrjInfo.Item "k" & str
    If m_iSavFlag = 1 And Err.Number = 0 Then '如果是增加数据,而数据已经存在,报错
        iShowMsg "项目编号冲突,请重新命名!"
        Exit Function
    ElseIf m_iSavFlag = 2 And Err.Number = 0 And ("k" & str) <> m_sCurUpdate Then '如果是更新数据,改变为不是所点击项目的编号,报错
        iShowMsg "项目编号冲突,请重新命名!"
        Exit Function
    End If
    
    '项目名称不能为空
    str = Trim(txtPrjName.Text)
    If Trim(str) = "" Then
        txtPrjName.SetFocus
        iShowMsg "项目名称不能为空!"
        Exit Function
    End If
    
    m_objTmp.Name = str
    m_objTmp.Memo = Trim(txtMemo.Text)
    bCheckPrjInfo = True
    Exit Function
End Function

'选中树视图中的一个节点
Private Sub SelectNode(sKey)
    On Error Resume Next
    If sKey = "k" Or IsNull(sKey) Then
        sKey = 1
    End If
    If treNode.Nodes.count <> 0 Then
        treNode.Nodes(sKey).Selected = True
        treNode_NodeClick treNode.Nodes(sKey)
    End If
End Sub

'清除项目信息集合
Private Sub Finalize()
    Dim tmp As clsPrjData
    
    treNode.Nodes.clear
    
    On Error Resume Next
    For Each tmp In m_objPrjInfo
        m_objPrjInfo.Remove tmp.key
        Set tmp = Nothing
    Next
    Err.clear
End Sub

Private Sub AddNew()
    Dim tmp As U8BudgetMgr.clsPrjData
    
    m_iSavFlag = 1
    Set m_objTmp = New U8BudgetMgr.clsPrjData
    ClearPrjInfo
    SetEdit
    
    '显示当前项目类型
    If m_sCurUpdate = "expend" Then
        cboPrjClass.ListIndex = 0
    ElseIf m_sCurUpdate = "income" Then
        cboPrjClass.ListIndex = 1
    Else
        Set tmp = m_objPrjInfo.Item(m_sCurUpdate)
        cboPrjClass.ListIndex = tmp.PrjClass
    End If
    lbUsed.Visible = False
    SetButtonState
End Sub

'依照记录集插入
Private Sub AppendRS(ByRef rs As ADODB.Recordset)
    Dim tmp As New U8BudgetMgr.clsPrjData
    
    Set tmp = New clsPrjData
    
    tmp.id = CInt(rs!iid)
    tmp.code = rs!sprjcode
    tmp.Name = rs!sprjname
    tmp.PrjClass = 0 - CBool(rs!bprjclass)
    tmp.PID = rs!iparentid
    tmp.Memo = IIf(IsNull(rs!smemo), "", rs!smemo)
    
    If tmp.PID = "0" Then   '如果是一级项目
        tmp.ParentCode = ""
        tmp.parentName = ""
    Else    '二级项目
        tmp.ParentCode = rs!sparentcode
        tmp.parentName = rs!sparentname
    End If
    
    AppendNode tmp
End Sub

'插入节点
Private Sub AppendNode(Node As U8BudgetMgr.clsPrjData)
    On Error Resume Next
    m_objPrjInfo.Add Node, Node.key
    If Node.PID = "0" Then
        If Node.PrjClass = 0 Then
            treNode.Nodes.Add "expend", tvwChild, Node.key, Node.Name
            treNode.Nodes.Item(Node.key).Image = "folder"
        Else
            treNode.Nodes.Add "income", tvwChild, Node.key, Node.Name
            treNode.Nodes.Item(Node.key).Image = "folder"
        End If
    Else
        treNode.Nodes.Add Node.ParentKey, tvwChild, Node.key, Node.Name
        treNode.Nodes.Item(Node.key).Image = "file"
    End If
End Sub

'设置菜单按钮
Private Sub LoadToolPic()
    With IltTool.ListImages
         .clear
         .Add , "add", LoadResPicture(323, vbResBitmap)
         .Add , "delete", LoadResPicture(326, vbResBitmap)
         .Add , "edit", LoadResPicture(324, vbResBitmap)
         .Add , "cancel", LoadResPicture(316, vbResBitmap)
         .Add , "refresh", LoadResPicture(154, vbResBitmap)
         .Add , "save", LoadResPicture(1145, vbResBitmap)
         .Add , "help", LoadResPicture(396, vbResBitmap)
         .Add , "quit", LoadResPicture(1118, vbResBitmap)
         .Add , "append", LoadResPicture(143, vbResBitmap)
         
    End With
    
    With IltTree.ListImages
        .clear
        .Add , "folder", LoadResPicture(1111, vbResBitmap)
        .Add , "file", LoadResPicture(1128, vbResBitmap)
        .Add , "foldersel", LoadResPicture(1112, vbResBitmap)
        .Add , "filesel", LoadResPicture(1102, vbResBitmap)
    End With
    
    Set treNode.ImageList = IltTree
    
    With tlbTool
         Set .ImageList = IltTool
         .Buttons("cancel").Image = "cancel"
         .Buttons("add").Image = "add"
         .Buttons("edit").Image = "edit"
         .Buttons("delete").Image = "delete"
         .Buttons("refresh").Image = "refresh"
         .Buttons("save").Image = "save"
         .Buttons("help").Image = "help"
         .Buttons("quit").Image = "quit"
         .Buttons("append").Image = "append"
    End With
    
    Me.Icon = LoadResPicture(109, vbResIcon)
End Sub

'设置菜大按钮状态
Private Sub SetButtonState()
    With tlbTool
        If treNode.Nodes.count <= 2 And m_iSavFlag <> 1 Then
            .Buttons("cancel").Enabled = False
            .Buttons("save").Enabled = False
            .Buttons("edit").Enabled = False
            .Buttons("add").Enabled = True
            .Buttons("refresh").Enabled = True
        ElseIf m_iSavFlag <> 0 Then '如果进行操作
            .Buttons("cancel").Enabled = True
            .Buttons("save").Enabled = True
            .Buttons("edit").Enabled = True
            .Buttons("delete").Enabled = False
            .Buttons("edit").Enabled = False
            .Buttons("add").Enabled = False
            .Buttons("refresh").Enabled = False
        Else    '
            .Buttons("cancel").Enabled = False
            .Buttons("save").Enabled = False
            
            .Buttons("add").Enabled = True
            .Buttons("refresh").Enabled = True
        End If
    End With
End Sub

Private Sub Quit()
    Unload Me
End Sub

'快捷键处理
Public Function bShortCut(KeyCode As Integer, Shift As Integer, Optional other As String) As Boolean
    Dim cmd As String
    Dim butt As MsComctlLib.Button
    
    On Error Resume Next
    bShortCut = True
    Select Case KeyCode
        Case vbKeyF1    '帮助
            cmd = "help"
        Case vbKeyF4    '刷新,退出
            If Shift = 1 Then
                cmd = "quit"
            Else
                cmd = "refresh"
            End If
        Case vbKeyF5    '增加新记录
            cmd = "new"
        Case vbKeyF6    '保存
            cmd = "save"
        Case vbKeyF12   '修改
            cmd = "save"
        Case vbKeyD    '删除
            cmd = "delete"
        Case vbKeySeparator, vbKeyReturn
            SendKeys "{tab}"
        Case Else
            bShortCut = False
            Exit Function
    End Select
    
    '激发菜单事件
    Set butt = tlbTool.Buttons(cmd)
    If Not butt Is Nothing Then
        If butt.Visible And butt.Enabled Then
            tlbTool_ButtonClick butt
        End If
    End If
End Function

''增加项目
'Private Sub AddData(Optional flag As Boolean = False)
'    Dim tmp As clsPrjData
'    Dim con As Connection
'    Dim rs As Recordset
'
'    If iCheck = vbCancel Then
'        Exit Sub
'    End If
'
'    If Not flag Then    '增加一级项目
'        Set m_objTmp = New clsPrjData
'        m_objTmp.ParentCode = ""
'        m_objTmp.Parentname = ""
'        SetEdit
'    Else    '增加二级项目
'        If (treNode.SelectedItem Is Nothing) Then
'            ishowmsg "请先选择一个一级父项目或同级项目!"
'            Exit Sub
'        End If
'        Set m_objTmp = New clsPrjData
'
'        '设置项目初始化信息
'        If lbParentCode.Caption = "" Then   '如果点中的是一级节点
'            m_objTmp.ParentCode = txtPrjCode.text
'            m_objTmp.Parentname = txtPrjName.text
'            Set tmp = m_objPrjInfo.Item(treNode.SelectedItem.Key)
'            m_objTmp.pId = tmp.id
'        Else    '如果是二级节点
'            m_objTmp.ParentCode = lbParentCode.Caption
'            m_objTmp.Parentname = lbParentName.Caption
'            Set tmp = m_objPrjInfo.Item("k" & lbParentCode.Caption)
'            m_objTmp.pId = tmp.id
'        End If
'        SetEdit
'
'        '设定节点的类型,和父节点一致
'        m_objTmp.PrjClass = tmp.PrjClass
'        cboPrjClass.ListIndex = m_objTmp.PrjClass
'        cboPrjClass.Enabled = False
'    End If
'
'    '清除以前的项目信息
'    ClearPrjInfo
'    m_iSavFlag = 1
'
'    '记录当前项目关键字
'    If Not (treNode.SelectedItem Is Nothing) Then
'        m_sCurUpdate = treNode.SelectedItem.Key
'    End If
'End Sub
Private Sub txtMemo_Change()

End Sub

Private Sub txtMemo_LostFocus()
    If m_iSavFlag <> 0 Then
        bCheckEdit 3
    End If
End Sub

Private Sub txtPrjCode_LostFocus()
    If m_iSavFlag <> 0 And Trim(txtPrjCode) <> "" Then
        bCheckEdit 1
    End If
End Sub

Private Sub txtPrjName_LostFocus()
    If m_iSavFlag <> 0 Then
        bCheckEdit 2
    End If
End Sub

Private Function bCheckEdit(Index As Integer)
    bCheckEdit = False
    Select Case Index
        Case 1  '项目编号
            If Not IsNumeric(txtPrjCode) Then
                iShowMsg "项目编号必须是数字!"
                txtPrjCode.SetFocus
                Exit Function
            End If
        Case 2  '项目名称
            If Len(Trim(txtPrjName)) > 80 Then
                iShowMsg "项目名称不能超过80字!"
                txtPrjName.SetFocus
                Exit Function
            End If
        Case 3  '项目说明
            If Len(Trim(txtMemo)) > 255 Then
                iShowMsg "项目说明不能超过255字!"
                txtMemo.SetFocus
                Exit Function
            End If
        Case Else   '其他
    End Select
    bCheckEdit = True
End Function