frmfi_zzpzset.frm

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

End Sub

Private Sub mnuUndo_Click()
        Call MainOption("undo")
End Sub

Private Sub mnuXg_Click()
        Call MainOption("edit")
End Sub

Private Sub tbrEdit_ButtonClick(ByVal Button As MSComctlLib.Button)
        Call MainOption(LCase(Button.Key))
End Sub

Private Sub MainOption(sMessage As String)
        Dim sID As String
        Dim sOldID As String          '编辑前序号
        Dim i As Integer
        Dim sErr As String
        Select Case sMessage
               Case "preview"
                    PrintMfg mFg, "转账凭证设置"
                Case "print"
                    PrintMfg2 mFg, "转账凭证设置"
               Case "add"
                    
                    frmFI_ZzpzAdd.IsOk = False      '编辑前的默认值
                    frmFI_ZzpzAdd.sFlag = "add"        '编辑方式
                    
                    frmFI_ZzpzAdd.Show 1
                    If frmFI_ZzpzAdd.IsOk = True Then
                       Call AddCbo          '不马上保存
                    End If
                    
               Case "edit"
                    
                    If cboZzXh.ListIndex < 0 Then
                       MsgBox "请选择要编辑的转账凭证序号，才能编辑！", vbExclamation, "提示"
                       Exit Sub
                    End If
                    
                    sOldID = Trim(cboZzXh.List(cboZzXh.ListIndex))
                    frmFI_ZzpzAdd.sOldxh = sOldID           '保存编辑前的转账序号
                    frmFI_ZzpzAdd.IsOk = False              '编辑前的默认值
                    frmFI_ZzpzAdd.sFlag = "edit"            '编辑方式
                    
                    frmFI_ZzpzAdd.Show 1
                    If frmFI_ZzpzAdd.IsOk = True Then           '返回变动三个信息（转账序号，转账类别，转账说明）
                       Call upDateRst(sOldID)                  '更新数据库
                       Call EditCbo
                    End If
                    
               Case "undo"
                    
                    If cboZzXh.ListIndex < 0 Then Exit Sub
                    Call FillOther
                    txtEdit.Visible = False
                    cmdHelp.Visible = False
               Case "addrow"
               
                     If cboZzXh.ListIndex < 0 Then
                       MsgBox "请选择转账凭证序号,才能添加行！", vbExclamation, "提示"
                       Exit Sub
                     End If
                    
                     mFg.Rows = mFg.Rows + 1
                     
                     mFg.RowHeight(mFg.Rows - 1) = 380           '设行高
                     
                     If mFg.Rows - 2 > 0 Then
                        mFg.TextMatrix(mFg.Rows - 1, COL_SUMMARY) = mFg.TextMatrix(mFg.Rows - 2, COL_SUMMARY)
                     Else
                        mFg.TextMatrix(mFg.Rows - 1, COL_SUMMARY) = Trim(cboZzsm.text)
                     End If
                     
                     mFg.row = mFg.Rows - 1        '得到焦点
                     mFg.col = COL_SUBJECT
                     
               Case "delrow"
               
                    If mFg.row > 0 Then
                        If MsgBox("是否删除当前行？", vbQuestion + vbYesNo, "提问") = vbYes Then
                           Call DelRow
                        End If
                    Else
                        MsgBox "请选则要删除的行！", vbExclamation, "提示"
                    End If
                    
                    cmdHelp.Visible = False
                    txtEdit.Visible = False
                    
               Case "delete"
               
                    If cboZzXh.ListIndex < 0 Then
                       MsgBox "请选择要删除转账凭证序号！", vbExclamation, "提示"
                       Exit Sub
                    End If
                    
                    If MsgBox("是否删除该凭证凭证编号?", vbYesNo + vbQuestion, "提示") = vbNo Then Exit Sub
                    
                    sID = Trim(cboZzXh.List(cboZzXh.ListIndex))
                    Call MoveCbo
                    Call DelRst(sID)
                    
               Case "save"
'           1:检查有无转账序号
                    If cboZzXh.ListIndex < 0 Then
                       MsgBox "请选择转账凭证号才能保存！", vbExclamation, "提示"
                       Exit Sub
                    End If
                    
                    If mFg.Rows < 2 Then
                       MsgBox "转账凭证无记录，不能保存！", vbExclamation, "提示"
                       Exit Sub
                    End If
                    
'　　　　　2.检查当前编辑,尚未读入MFG
                    If txtEdit.Visible = True Then
                       If checkTxtEdit = False Then        'false  :有错  true 正确
                          Exit Sub
                       End If
                    End If
                    

                    
'          3.检查是否空格,其他的合法性判断在输入时控制
                   
                    If checkMfgKG() = True Then         'True : 有空格 /检查各分录（科目代码，方向，金额公式）不能为空）
                       Exit Sub
                    End If
'          4.检查公式是否合法
                    sErr = ""
                    For i = 1 To mFg.Rows - 1
                        sErr = CheckUserFormulaErr(mFg.TextMatrix(i, COL_FORMULA))
                        If sErr <> "" Then Exit For
                    Next
                    If sErr <> "" Then MsgBox "公式不合法，不能保存！请检查公式。", vbInformation, "": Exit Sub
                    Call DelRst(Trim(cboZzXh.List(cboZzXh.ListIndex)))         '先删除
                    Call RstSave        '再保存
                    cmdHelp.Visible = False
                    txtEdit.Visible = False
                    
'           可以保存了

               Case "help"
                    SendKeys "{F1}"
                    
               Case "quit"
                    Unload Me
               
        End Select
End Sub

Private Sub RstSave()             '保存转账凭证设置
        Dim rstTmp As New ADODB.Recordset
        Dim iR As Integer
        
        With rstTmp
            .CursorLocation = adUseClient
            .Open "select * from tzw_zzpzset" & glo.sOperateYear, glo.cnnMain, adOpenStatic, adLockOptimistic
            For iR = 1 To mFg.Rows - 1
                .AddNew
                .Fields("id").value = Trim(cboZzXh.List(cboZzXh.ListIndex))
                .Fields("cpzlb").value = Trim(lbPzlb.Caption)
                .Fields("czzsm").value = Trim(cboZzsm.List(cboZzsm.ListIndex))
                .Fields("czy").value = Trim(mFg.TextMatrix(iR, COL_SUMMARY))
                .Fields("sijlhm").value = iR
                .Fields("ckmdm").value = GetCode(Trim(mFg.TextMatrix(iR, COL_SUBJECT)))
                .Fields("cfx").value = Trim(mFg.TextMatrix(iR, COL_DIRECT))
                .Fields("cjegs").value = Trim(mFg.TextMatrix(iR, COL_FORMULA))
                .Fields("cPzType").value = m_sPzType
                .Fields("Xmdm").value = GetCode(Trim$(mFg.TextMatrix(iR, COL_ITEM)))
                .Fields("Xmmc").value = GetName(Trim$(mFg.TextMatrix(iR, COL_ITEM)))
                .Fields("Bmdm").value = GetCode(Trim$(mFg.TextMatrix(iR, COL_DEPARTMENT)))
                .Fields("Bmmc").value = GetName(Trim$(mFg.TextMatrix(iR, COL_DEPARTMENT)))
                .Update
            Next iR
            .Close
    End With
End Sub
Private Function checkTxtEdit() As Boolean      'False  :有错  True 正确
        Dim errTS As String      '错误提示
        Dim rstTmp As New ADODB.Recordset
        rstTmp.CursorLocation = adUseClient
        checkTxtEdit = False    '漠认无错

        Select Case mFg.col             '摘要|>科目代码|>方向|>金额公式
               Case COL_SUMMARY
                    If Len(Trim(txtEdit.text)) > 100 Then
                       errTS = "摘要长度不能超100！"
                       GoTo Err         '如果要当前编辑，可以去掉所有的 goto err 语句
                    End If
               Case COL_SUBJECT       '科目检查
                    If Not CheckHave("tzw_km" & glo.sOperateYear, txtEdit, "kmdm", "kmmc", Trim(txtEdit.text), "IsEndKm=-1") Then
                       errTS = "科目代码或名称不存在,或者科目不是明细科目！"
                       GoTo Err
                    End If
               Case COL_ITEM
                     If Not CheckHave("tzw_Item" & glo.sOperateYear, txtEdit, "cCode", "cName", Trim(txtEdit.text)) And txtEdit.text <> "" Then
                        errTS = "项目代码或名称不存在！"
                        GoTo Err
                     End If
                Case COL_DEPARTMENT
                     If Not CheckHave("tUsu_Department" & glo.sOperateYear, txtEdit, "CDepCode", "CDepName", Trim(txtEdit.text), "BDepEnd=-1") And txtEdit.text <> "" Then
                        errTS = "部门代码或名称不存在！，或者不是末级部门！"
                        GoTo Err
                     End If
               Case COL_DIRECT       '方向
                    If Trim(txtEdit.text) <> "借" Then
                       If Trim(txtEdit.text) <> "贷" Then
                          errTS = "方向只能为借或贷！"
                          GoTo Err
                       End If
                    End If
                    
               Case COL_FORMULA       '公式检查
                    If Len(Trim(txtEdit.text)) > 200 Then
                       errTS = "公式长度不能超过200！"
                       GoTo Err
                    End If
                    
                    errTS = ""
                    errTS = CheckUserFormulaErr(Trim(txtEdit.text))           '检查公式正确否
                    If errTS <> "" Then
                        mFg.Tag = errTS
                        GoTo Err
                    End If
                    
        End Select
        
        mFg.TextMatrix(mFg.row, mFg.col) = Trim(txtEdit.text)         '正确时存入mfg
        checkTxtEdit = True
        
        Exit Function
        
Err:  MsgBox errTS, vbExclamation, "提示"

End Function

Private Function checkMfgKG() As Boolean    'true 有空格

    Dim iRR As Integer
    Dim icc As Integer

        For iRR = 1 To mFg.Rows - 1
            For icc = 0 To mFg.Cols - 1
                Select Case icc
                Case COL_SUBJECT, COL_SUMMARY, COL_DIRECT, COL_FORMULA
                    If Trim(mFg.TextMatrix(iRR, icc)) = "" Then
                       MsgBox "当前格不能为空！", vbExclamation, "提示"
                       mFg.row = iRR
                       mFg.col = icc
                       checkMfgKG = True
                       Exit Function
                    End If
                End Select
            Next
        Next iRR
        checkMfgKG = False
        
End Function
Private Sub AddCbo()

         Dim iTmp As Integer
         cboZzXh.AddItem newZzxh
         cboZzsm.AddItem newZzsm, cboZzXh.NewIndex
         iTmp = UBound(sPzlb) + 1
         ReDim Preserve sPzlb(iTmp)
         cboZzXh.ItemData(cboZzXh.NewIndex) = iTmp
         sPzlb(iTmp) = newZzlb
         cboZzXh.ListIndex = cboZzXh.NewIndex
         
End Sub

Private Sub EditCbo()

         Dim iListIndex As Integer
         Dim iIdex As Integer
         
            iListIndex = cboZzXh.ListIndex
            iIdex = cboZzXh.ItemData(iListIndex)
            
            cboZzXh.RemoveItem iListIndex
            cboZzsm.RemoveItem iListIndex
            
            
            cboZzXh.AddItem newZzxh             '调整后放入数组后
            cboZzsm.AddItem newZzsm, iListIndex
            
            cboZzXh.ItemData(cboZzXh.NewIndex) = iIdex
            sPzlb(iIdex) = newZzlb
            
            cboZzXh.ListIndex = cboZzXh.NewIndex
            
End Sub

Private Sub upDateRst(sID As String)

    'sID 要更新的凭证序号
        Dim cmmTmp As New ADODB.Command
        
        cmmTmp.ActiveConnection = glo.cnnMain
        cmmTmp.CommandText = "update tzw_zzpzset" & glo.sOperateYear & " set id='" & newZzxh & _
                           "',czzsm='" & newZzsm & "',cpzlb='" & newZzlb & "' where id='" & sID & "' and cPzType='" & m_sPzType & "'"
        cmmTmp.Execute
        
End Sub

Private Sub MoveCbo()

        Dim iIndex As Integer
        Dim iTmp As Integ