frmin_jsfs.frm

一个用VB写的财务软件源码

            .TextMatrix(iRC, 0) = Trim$("" & rstAllJs.Fields("cCode"))
            .TextMatrix(iRC, 1) = Trim$("" & rstAllJs.Fields("cName"))
            .TextMatrix(iRC, 2) = IIf(rstAllJs.Fields("bFlag"), "是", "否")
            rstAllJs.MoveNext
            iRC = iRC + 1
        Wend
    End With
     If strPrt = "PRINT" Then
        PrintMfg2 frmUSU_Print.mfgPrt, "结算方式"  '2002.1.24zhouwei
     Else
        PrintMfg frmUSU_Print.mfgPrt, "结算方式"  '2002.1.24zhouwei
     End If
    
End Sub


Private Sub Operate(strKey As String)
    Dim strTemp As String
    Dim Node As Node
    Dim Level As Integer
    Dim tNode As Node
    Select Case strKey
        Case "PRINT"
            Call PrintAll("PRINT")
            
        Case "PREVIEW"
               Call PrintAll("PREVIEW")
        Case "ADD"
            On Error GoTo Err
           
            txtName = ""
            Level = 1
            Set Node = tvwJs.SelectedItem
            If Node.Key <> "R" Then
               If Not Useing("不可增加！") Then Exit Sub
            End If
            While Node.Key <> "R"
                Set Node = Node.Parent
                Level = Level + 1
            Wend
            rstJsJc.Filter = "JC=" & Level
            rstJsJc.Requery
            txtJc = Level
            chkFlag.value = 0
            chkEnd.value = 1
            
            txtID.Mask = Right(tvwJs.SelectedItem.Key, Len(tvwJs.SelectedItem.Key) - 1) & String(rstJsJc.Fields("Ws"), "a")
            txtID = Right(tvwJs.SelectedItem.Key, Len(tvwJs.SelectedItem.Key) - 1) & String(rstJsJc.Fields("WS"), "_")
            rstJsJc.Filter = adFilterNone
            rstJsJc.Requery
            
            tbrJs.Buttons("Save").Tag = "1"         '置新增标志
            tbrJs.Buttons("Save").Enabled = True
            tbrJs.Buttons("Delete").Enabled = False
            tbrJs.Buttons("Cancel").Enabled = True
            tbrJs.Buttons("Add").Enabled = False
            mnuSave.Enabled = True
            mnuDelete.Enabled = False
            mnuCancel.Enabled = True
            txtID.Enabled = True
            txtID.SelStart = Len(tvwJs.SelectedItem.Key) - 1
            txtID.SetFocus
        Exit Sub
Err:
    MsgBox "请选择要添加的节点！", vbInformation
        Case "DELETE"
            On Error Resume Next
            If Useing("不可删除！") Then
                If MsgBox("确认要删除此结算方式吗？", vbQuestion + vbYesNo, "提示") = vbYes Then
                    Dim rstJsfs As New ADODB.Recordset
                    Dim sSQL As String
                    Dim sTemp As String
                    Dim iLevel As Integer
                    Set Node = tvwJs.SelectedItem.Parent
                    
                    sTemp = Trim(rstJs.Fields("ccode").value & "")
                    rstJs.Delete
                    rstJsfs.CursorLocation = adUseClient
                    iLevel = InStr(sbrLevel.Panels(2).text, " ") - 1
                    sSQL = "select * from tzw_jsfs" & glo.sOperateYear & " where ccode like '" & Left(sTemp, iLevel) & "%'"
                    rstJsfs.Open sSQL, glo.cnnMain, adOpenStatic, adLockOptimistic
                    If rstJsfs.RecordCount < 2 Then
                       rstJsfs.Close
                       sSQL = "update tzw_jsfs" & glo.sOperateYear & " set igrade=1 , bend=-1 where ccode=" & Left(sTemp, iLevel)
                       rstJsfs.Open sSQL, glo.cnnMain, adOpenStatic, adLockOptimistic
                    End If
                    rstJsfs.Close
                    Set rstJsfs = Nothing

                    tvwJs.Nodes.Remove (tvwJs.SelectedItem.Index)
                    tvwJs_NodeClick Node
                End If
            End If
        Case "SAVE"
            On Error Resume Next
            If ValidAll Then
                '将其上级节点的末级标志置为0
               
                If tvwJs.SelectedItem.Key <> "R" Then
                    rstJs.Filter = "cCode='" & Right(tvwJs.SelectedItem.Key, Len(tvwJs.SelectedItem.Key) - 1) & "'"
                    rstJs.Requery
                    rstJs.Fields("bEnd") = 0
                    rstJs.Filter = "cCode='" & Trim$("" & txtID) & "'"
                    rstJs.Requery
                End If
                
                If tbrJs.Buttons("Save").Tag = "1" Then
                    rstJs.AddNew
                    rstJs.Fields("cCode") = Trim$("" & txtID)
                End If
                rstJs.Fields("cName") = Trim$("" & txtName.text)
                rstJs.Fields("bFlag") = IIf(chkFlag.value = 1, True, False)
                rstJs.Fields("iGrade") = txtJc.text
                rstJs.Fields("bEnd") = IIf(chkEnd.value = 1, True, False)
                rstJs.Update
                
                '提示是否其下所有节点全部替换
    
                If tvwJs.SelectedItem.Children > 0 And chkFlag = 1 Then
                    If MsgBox("更改影响其下属所有结算方式的票据标志吗？", vbQuestion + vbYesNo, "提示") = vbYes Then
                        glo.cnnMain.Execute "UPDATE tZW_Jsfs" & glo.sOperateYear & " SET bFlag=" & Trim$("" & str(chkFlag)) & " where cCode like '" & Right(tvwJs.SelectedItem.Key, Len(tvwJs.SelectedItem.Key) - 1) & "%'"
                    End If
                End If
                '加载树节点
                If tbrJs.Buttons("Save").Tag = "1" Then
                    If tvwJs.SelectedItem.Children > 0 Then
                        Set tNode = tvwJs.SelectedItem.Child
                        Do While Not tNode Is Nothing
                            If tNode.Key > "A" & Trim$("" & txtID) Then Exit Do
                            Set tNode = tNode.Next
                        Loop
                        If tNode Is Nothing Then
                            tvwJs.Nodes.Add tvwJs.SelectedItem.Key, tvwChild, "A" & Trim$("" & txtID), Trim$("" & txtID) + "=" + Trim$("" & txtName), "Collapse", "Expand"
                        Else
                            tvwJs.Nodes.Add tNode.Key, tvwPrevious, "A" & Trim$("" & txtID), Trim$("" & txtID) + "=" + Trim$("" & txtName), "Collapse", "Expand"
                        End If
                    Else
                        tvwJs.Nodes.Add tvwJs.SelectedItem.Key, tvwChild, "A" & Trim$("" & txtID), Trim$("" & txtID) + "=" + Trim$("" & txtName), "Collapse", "Expand"
                    End If
                    tvwJs.Nodes("A" & Trim$("" & txtID)).Selected = True
                Else
                    tvwJs.SelectedItem = Trim$("" & txtID) + "=" + Trim$("" & txtName)
                End If
                
                tvwJs_NodeClick tvwJs.SelectedItem
                txtID.Enabled = False
                tbrJs.Buttons("Cancel").Enabled = False
                mnuCancel.Enabled = False
                tbrJs.Buttons("Save").Tag = ""
            End If
        Case "CANCEL"
            tvwJs_NodeClick tvwJs.SelectedItem
            tbrJs.Buttons("Add").Enabled = True
            tbrJs.Buttons("Save").Enabled = False
            tbrJs.Buttons("Save").Tag = ""
            tbrJs.Buttons("Cancel").Enabled = False
            mnuNew.Enabled = True
            mnuSave.Enabled = False
            mnuCancel.Enabled = False
        Case "HELP"
             Dim nRet As Integer
    
            If Len(App.HelpFile) = 0 Then
                MsgBox "Unable to display Help Contents. There is no Help associated with this project.", vbInformation
            Else
                On Error Resume Next
                nRet = HtmlHelp(Me.hwnd, App.Path & "\Help Files\" & App.ProductName & ".chm", _
                HH_HELP_CONTEXT, CLng(Me.HelpContextID))
                If Err Then
                    MsgBox Err.Dscription
                End If
            End If
        Case "EXIT"
            Unload Me
    End Select
    Set Node = Nothing

End Sub

Private Function Useing(sTemp As String) As Boolean
    Dim rstChkTemp As New ADODB.Recordset
    
    Useing = False
    With rstChkTemp
        .CursorLocation = adUseClient
        .Open "select yhdz_jsfs from tZW_pzsj" & glo.sOperateYear & " where yhdz_jsfscode='" & Trim(rstJs.Fields("cCode") & "") & "'", glo.cnnMain, adOpenStatic, adLockOptimistic
        If Not (.BOF And .EOF) Then
            MsgBox "已在凭证中引用," & sTemp, vbInformation
            Exit Function
        Else
            .Close
            .Open "select jsfsCode from tZW_yhdzd" & glo.sOperateYear & " where jsfsCode='" & Trim(rstJs.Fields("cCode") & "") & "'", glo.cnnMain, adOpenStatic, adLockOptimistic
            If Not (.BOF And .EOF) Then
                MsgBox "已做过银行对账单," & sTemp, vbInformation
                Exit Function
            End If
        End If
    End With
    Useing = True
End Function

Private Function ValidAll() As Boolean
    ValidAll = False
    
    If InStr(txtID, "_") > 0 Then
        MsgBox "结算方式编码不全！", vbInformation
        txtID.SetFocus
        Exit Function
    ElseIf Trim$("" & txtName) = "" Then
        MsgBox "结算方式名称不能为空！", vbInformation
        txtName.SetFocus
        Exit Function
    Else
        '判断是否已有此编码
        rstJs.Requery
        rstJs.Filter = "cCode='" & Trim$("" & txtID) & "'"
        
        If rstJs.BOF And rstJs.EOF Then
            rstJs.Filter = adFilterNone
            rstJs.Requery
        ElseIf tbrJs.Buttons("Save").Tag = "1" Then
            MsgBox "结算方式(" & Trim(txtID.text) & Trim(rstJs.Fields("cName").value & "") & ")代码重复！", vbInformation
            rstJs.Filter = adFilterNone
            rstJs.Requery
            Exit Function
        Else
            '保留过滤
        End If
    End If
    
    ValidAll = True
End Function

Private Sub tvwJs_NodeClick(ByVal Node As MSComctlLib.Node)
    Dim i As Integer
    Dim s As String
    
    If tvwJs.SelectedItem.Key = "R" Then
        txtID.Mask = ""
        txtID = ""
        txtName = ""
        txtJc = ""
        chkFlag.value = 0
        chkEnd.value = 0
        
        If Not (rstJsJc.BOF And rstJsJc.EOF) Then tbrJs.Buttons("Add").Enabled = True
        tbrJs.Buttons("Delete").Enabled = False
        tbrJs.Buttons("Save").Enabled = False
        mnuDelete.Enabled = False
        mnuSave.Enabled = False
    Else
        
        With rstJs
            .Requery
            .Filter = adFilterNone
            If .BOF And .EOF Then
            Else
                .MoveFirst
'                .Find "cCode='" & Right(tvwJs.SelectedItem.Key, Len(tvwJs.SelectedItem.Key) - 1) & "'"
                Do Until .EOF
                    If Trim$("" & .Fields("cCode").value) = Right(tvwJs.SelectedItem.Key, Len(tvwJs.SelectedItem.Key) - 1) Then
                        txtID.Mask = Trim(.Fields("cCode") & "")
                        txtID = Trim(.Fields("cCode") & "")
                        txtName = Trim(.Fields("cName") & "")
                        txtJc = .Fields("iGrade")
                        chkFlag.value = IIf(.Fields("bFlag").value, 1, 0)
                        chkEnd.value = IIf(.Fields("bEnd").value, 1, 0)
                        Exit Do
                    End If
                    .MoveNext
                Loop
            End If
        End With
        If tvwJs.SelectedItem.Children = 0 Then
            tbrJs.Buttons("Delete").Enabled = True
            mnuDelete.Enabled = True
        Else
            tbrJs.Buttons("Delete").Enabled = False
            mnuDelete.Enabled = False
        End If
        If Len(Right(tvwJs.SelectedItem.Key, Len(tvwJs.SelectedItem.Key) - 1)) = LevLen Then
            tbrJs.Buttons("Add").Enabled = False
            mnuNew.Enabled = False
        Else
            tbrJs.Buttons("Add").Enabled = True
            mnuNew.Enabled = True
        End If
        tbrJs.Buttons("Save").Enabled = True
        mnuSave.Enabled = True
    End If
    lvwJs.ListItems.Clear
    If tvwJs.SelectedItem.Children > 0 Then
        i = tvwJs.SelectedItem.Child.Index
        lvwJs.ListItems.Add , tvwJs.Nodes.Item(i).Key, Right(tvwJs.Nodes.Item(i).text, Len(tvwJs.Nodes.Item(i)) - InStr(tvwJs.Nodes.Item(i), "=")), "large", "small"
        While i <> tvwJs.SelectedItem.Child.LastSibling.Index
            i = tvwJs.Nodes.Item(i).Next.Index
            lvwJs.ListItems.Add , tvwJs.Nodes.Item(i).Key, Right(tvwJs.Nodes.Item(i).text, Len(tvwJs.Nodes.Item(i)) - InStr(tvwJs.Nodes.Item(i), "=")), "large", "small"
        Wend
    Else
        lvwJs.ListItems.Add , tvwJs.SelectedItem.Key, Right(tvwJs.SelectedItem, Len(tvwJs.SelectedItem) - InStr(tvwJs.SelectedItem, "=")), "large", "small"
    End If
End Sub

Private Sub txtID_KeyPress(KeyAscii As Integer)
    If (KeyAscii >= Asc("0") And KeyAscii <= Asc("9")) Or KeyAscii = 13 Or KeyAscii = 8 Then
        If KeyAscii = 13 Then SendKeys "{TAB}"
    Else
        KeyAscii = 0
    End If
End Sub

Private Sub txtName_GotFocus()
    txtName.IMEMode = 1
End Sub

Private Sub txtName_LostFocus()
    txtName.IMEMode = 2
End Sub