-+

VB财务软件系统下载源代码提供自由下载使用学习

                Gen_Key "FirstPage"
            End If
        Case vbKeyPageDown
            If Shift = 0 And Tlbckd.Buttons("NextPage").Enabled Then
                Gen_Key "NextPage"
            ElseIf Shift = 2 And Tlbckd.Buttons("LastPage").Enabled Then
                Gen_Key "LastPage"
            End If
    End Select
End Sub

Private Sub Gen_Key(TLB_Key As String)
    On Error Resume Next
    Select Case TLB_Key
        Case Is = "Print", "Preview", "Dataout"
            zjPrnViewOut Me, "nbjsdj", TLB_Key
        Case Is = "AddRecord"   '增加
            Dim xf As Boolean
            xf = True
            If Not isSave Then
                Select Case PromptSav
                    Case vbYes:
                        If Ckdquit() Then
                            CkdSave
                            xf = isSave
                        Else
                            xf = False
                        End If
                    Case vbNo:
                    
                    Case vbCancel:
                        xf = False
                End Select
            End If
            If xf Then
                Ckdappe
                Tlbckd.Buttons("DeleteRecord").Image = "DeleteRecord"
                Tlbckd.Buttons("DeleteRecord").Caption = "删除"
                Tlbckd.Buttons("DeleteRecord").ToolTipText = "Ctrl+Y"
                Tlbckd.Buttons("CopyRecord").Image = "PasteRecord"
                Tlbckd.Buttons("CopyRecord").Caption = "粘贴"
                Tlbckd.Buttons("CopyRecord").ToolTipText = "Ctrl+V"
            End If
        Case Is = "SaveRecord"  '存盘
            If Ckdquit() Then
                CkdSave
                If isSave Then
                    Tlbckd.Buttons("DeleteRecord").Image = "DeleteRecord"
                    Tlbckd.Buttons("DeleteRecord").Caption = "删除"
                    Tlbckd.Buttons("DeleteRecord").ToolTipText = "Ctrl+Y"
                    Tlbckd.Buttons("CopyRecord").Image = "CopyRecord"
                    Tlbckd.Buttons("CopyRecord").Caption = "复制"
                    Tlbckd.Buttons("CopyRecord").ToolTipText = "Ctrl+C"
                    Combo1_GotFocus 'cuidong 2001.08.24
                End If
                'Combo1_GotFocus    'cuidong 2001.08.24
            End If
        Case Is = "DeleteRecord"  '删除
            If IsNew Or isSave Then
                If PromptDel = vbYes Then
                    Ckddele
                    Tlbckd.Buttons("CopyRecord").Image = "CopyRecord"
                    Tlbckd.Buttons("CopyRecord").Caption = "复制"
                    Tlbckd.Buttons("CopyRecord").ToolTipText = "Ctrl+C"
                    Getckd IIf(IsNew, 4, 2), Editbh.Text
                End If
            Else
                Getckd 3, IIf(Editbh.Text = "00000000", "0", Right(str(99999999 + Editbh.Text), 8))
                Tlbckd.Buttons("DeleteRecord").Image = "DeleteRecord"
                Tlbckd.Buttons("DeleteRecord").Caption = "删除"
                Tlbckd.Buttons("DeleteRecord").ToolTipText = "Ctrl+Y"
            End If
        Case Is = "CopyRecord"
            Setdjcopy IsNew
        Case Is = "FirstPage"     '首页
            Getckd 1, Editbh.Text
         Case Is = "PriorPage"    '上页
            Getckd 2, Editbh.Text
        Case Is = "NextPage"      '下页
            Getckd 3, Editbh.Text
        Case Is = "LastPage"     '末页
            Getckd 4, Editbh.Text
        Case Is = "Check"       '复核
            InitFrmCheck_xz True
            If CheckStatus = 0 Then
                Check "One"
            ElseIf CheckStatus = 1 Then
                Check "All"
            End If
        Case Is = "CheckCancel"    '取消复核
            InitFrmCheck_xz False
            If CheckStatus = 0 Then
                UnCheck "One"
            ElseIf CheckStatus = 1 Then
                UnCheck "All"
            End If
        Case Is = "PingZheng"
            With pzInfo
               .pDjrq = Editrq.Text
               .pMoney = Editje(0)
               .pYwID = rsTckd![cSetid]
               .pZhID1 = Edityhzh(0).Text
               .pZhID2 = Edityhzh(1).Text
               .pDigest = Editzy(0).Text
               .pHl = Editje(1)
               .blnFind = False
            End With
            If Err.Number <> 0 Then
                Gen_Key "NextPage"
                Exit Sub
            Else
                If ZjAccInfo.zjPrnCtrl Then Exit Sub
                ZjAccInfo.zjPrnCtrl = True
                DoVouch
                ZjAccInfo.zjPrnCtrl = False
            End If
        Case Is = "Help"
            SendKeys "{F1}"
        Case Is = "Exit"       '退出
            Unload Me
            Exit Sub
    End Select
    ckdbutt
End Sub
' 新增单据存盘合法性检查
Private Function Ckdquit() As Boolean
    If isSave Then
        Ckdquit = True
        Exit Function
    End If
    
    Ckdquit = False
    
    If Editbh.Text = "" Then
        Beep
        MsgBox "业务编号不能为空，请检查！", vbCritical, zjGl_Name
        Editbh.SetFocus
        Exit Function
    Else
        Editbh.Text = Right("00000000" & Editbh.Text, 8)
    End If
    
    If Editrq.Text = "" Then
        Beep
        MsgBox "业务日期不能为空，请检查！", vbCritical, zjGl_Name
        Editrq.SetFocus
        Exit Function
    End If
    
    Editrq.Text = ForDate(Editrq.Text)
    If Not IsDate(Editrq.Text) Then
        Beep
        MsgBox "日期非法，请检查！", vbCritical, zjGl_Name
        SetTxtFocus Editrq
        isEnt(0) = False
        Exit Function
    End If
    
    If CDate(Editrq.Text) > zjLogInfo.curDate Then
        Beep
        MsgBox "业务日期不能超过系统登录时间！", vbCritical, zjGl_Name
        SetTxtFocus Editrq
        Exit Function
    End If
    
    If Jszh_err(Editrq.Text, False, Edityhmc(0), Edityhzh(0), Edityhzh(1), Textbb, 2, 0, True, False) Then
        SetTxtFocus Edityhzh(0)
        isEnt(3) = False
        Exit Function
    End If
    
    If Jszh_err(Editrq.Text, False, Edityhmc(1), Edityhzh(1), Edityhzh(0), Textbb, 1, 0, False, True) Then
        SetTxtFocus Edityhzh(1)
        isEnt(4) = False
        Exit Function
    End If
    
    If Editje(0).Text = "" Then
        Beep
        MsgBox "结算金额不能为空，请检查！", vbCritical, zjGl_Name
        Editje(0).SetFocus
        Exit Function
    End If
    
    If Val(Editje(0).Text) = 0 Then
        Beep
        MsgBox "结算金额不能为0，请检查!", vbCritical, zjGl_Name
        SetTxtFocus Editje(0)
        Exit Function
    End If
    
    If Editje(1).Text = "" Then
        Beep
        MsgBox "汇率不能为空，请检查！", vbCritical, zjGl_Name
        Editje(1).SetFocus
        Exit Function
    End If
    
    If Val(Editje(1).Text) = 0 Then
        Beep
        MsgBox "汇率不能为0，请检查！", vbCritical, zjGl_Name
        SetTxtFocus Editje(1)
        Exit Function
    End If
    
    If CheckCurrencyOut(CDbl(Textje.Text)) Then
         SetTxtFocus Editje(0)
         Exit Function
    End If
    
    Dim ye As Double
    ye = 0
    On Error GoTo err2
    If Not IsNew Then
        If rsTckd![cPAccID] = Edityhzh(1).Text Then
            ye = rsTckd![mMoney]
        End If
    End If
err2:
    ye = ye + Gethqzhye(Edityhzh(1).Text)
    If ye < CDbl(Editje(0).Text) Then
        Beep
        If HqzhRedcx(Edityhzh(1).Text, ye - CDbl(Editje(0).Text)) Then
            SetTxtFocus Editje(0)
            Exit Function
        End If
    End If
    
    Ckdquit = True
    
End Function
''''''获得单据最大业务号
'''''Private Function Getmaxbh()
'''''    Dim rsTemp As New UfRecordset, i As Long
'''''    Set rsTemp = dbsZJ.OpenRecordset("FD_settacc", dbOpenTable)
'''''    With rsTemp
'''''        .Index = "PrimaryKey"
'''''        If .EOF Then
'''''            Getmaxbh = "00000001"
'''''        Else
'''''            .MoveLast
'''''            If ![cSetID] Like "15*" Then
'''''                Getmaxbh = Right(str(100000001 + Right(![cSetID], 8)), 8)
'''''            Else
'''''                Getmaxbh = "00000001"
'''''            End If
'''''            If Getmaxbh = "00000000" Then
'''''            For i = 1 To 99999998
'''''                Getmaxbh = Right(str(100000000 + i), 8)
'''''                .oSeek "=", "15" & oV.hasMadePZ
'''''                If .EOF Then
'''''                    Exit Function
'''''                End If
'''''            Next
'''''        End If
'''''        End If
'''''        .Close
'''''    End With
'''''End Function
'单据删除
Private Sub Ckdappe()
    Textqk
    Editbh.Text = oV.getMaxID("15")
    IsNew = True
End Sub
Private Sub CkdSave()
    On Error Resume Next
    Dim sav_js As Integer
    If isSave Then Exit Sub
    sav_js = 0
cf: CkdSave1
'cuidong 2001.08.24
'------------------------
'    If Not isSave Then
'        sav_js = sav_js + 1
'        If sav_js < 1000 Then GoTo cf
'        Beep
'        MsgBox "其他工作站正在保存，请过一会儿再试！", vbOKOnly + vbInformation, zjGl_Name
'    End If
'------------------------
End Sub
'单据存盘
Private Sub CkdSave1()
    Dim newmaxbh As String, rsTemp As New UfRecordset, oldbh As String
    Dim sID As String
    
    On Error GoTo er1
    newmaxbh = "15" & Editbh.Text
    BillSaveLock "15"  'cuidong 2001.08.28
    If IsNew Then
'''''        Set rsTemp = dbsZJ.OpenRecordset("FD_Settacc", dbOpenTable)
'''''        With rsTemp
'''''            .Index = "PrimaryKey"
'''''            .oSeek "=", newmaxbh
'''''            If Not .EOF Then
'''''                .MoveLast
'''''                newmaxbh = "15" & Right(str(100000001 + Right(![cSetID], 8)), 8)
'''''                Editbh.Text = Right(newmaxbh, 8)
'''''            End If
'''''            .Close
'''''        End With
'''''        rsTckd.AddNew
            'cuidong 2001.08.23
            '-----------------------------
'            If oV.IDExists(newmaxbh) Then newmaxbh = oV.getMaxID("15")
            If oV.IDExists(newmaxbh) Then
               sID = "15" & oV.getMaxID("15")
               'MsgBox "编号‘" & Right$(newmaxbh, 8) & "’已存在，系统将使用新编号‘" & Right$(sID, 8) & "’"
               newmaxbh = sID
               Editbh.Text = Right$(sID, 8) 'cuidong 2001.08.24
            End If
            '-----------------------------
    Else
        Label1(17).Caption = IIf(IsNull(rsTckd![cCheckCode]), "", rsTckd![cCheckCode])
        If Label1(17).Caption <> "" Then
            Beep
            MsgBox "对不起，这张单子已被审核过！", vbOKOnly + vbInformation, zjGl_Name
            Carddata
            isSave = True
            Exit Sub
        End If
''''        rsTckd.edit
    End If
    Savdata newmaxbh
    BillSaveUnLock "15"  'cuidong 2001.08.28
    Exit Sub
er1:
    Select Case Err.Number
    Case 3167
        IsNew = True
        Savdata newmaxbh
    
    Case 3022
        Savdata "15" & oV.getMaxID("15")
    
    Case Else
        BillSaveUnLock "15"  'cuidong 2001.08.28
    
    End Select
End Sub
' 给窗体赋值
Private Sub Carddata()
    With rsTckd
        If Not .EOF Then
            Frtin = True
            Editrq.Text = Format(![dbill_date], "yyyy-mm-dd")
            Editbh.Text = Right(![cSetid], 8)
            Edityhzh(0).Text = ![cGAccID]
            Edityhmc(0).Text = Zhbhtodwmc(Edityhzh(0).Text)
            Edityhzh(1).Text = ![cPAccID]
            Edityhmc(1).Text = Zhbhtodwmc(Edityhzh(1).Text)
            Textbb.Text = Wgetwbb(Edityhzh(0).Text)
            Editje(1).Text = ![nFrat]
            Editje(0).Text = Format(![mMoney], "#0.00")
            Textje.Text = Format(![mMoney_F], "#0.00")
            Editzy(0).Text = IIf(IsNull(![cDigest]), "", ![cDigest])
            Editzy(1).Text = IIf(IsNull(![crun_name]), "", ![crun_name])
            Editzy(2).Text = IIf(IsNull(![cpay_name]), "", ![cpay_name])
            Editzy(3).Text = IIf(IsNull(![cset_name]), "", ![cset_name])
            
            Label1(17).Caption = IIf(IsNull(![cCheckCode]), "", ![cCheckCode])
            Label1(19).Caption = IIf(IsNull(![cBookCode]), "", ![cBookCode])
            Label1(21).Caption = ![cBillCode]
            Frtin = False
        Else
            Textqk
        End If
    End With
    isSave = True
    IsNew = False
End Sub
' 给表赋值
Private Sub Savdata(bh As String)
    With oVd
        .Add "dbill_date", Editrq.Text
        .Add "cSetid", bh
        .Add "cGAccID", Edityhzh(0).Text