来自「VB开发的ERP系统」· 代码 · 共 1,519 行 · 第 1/5 页

            If Tlb_Action.Buttons("dy").Enabled Then Call bbyl(False)
        End Select
    End If
    Select Case KeyCode
    Case vbKeyF3          '修改
        If Tlb_Action.Buttons("xg").Enabled Then
            Call Sub_EditBill
        End If
    Case vbKeyF6          '保存凭证
        If Tlb_Action.Buttons("bc").Enabled Then
            Call Sub_SaveBill
        End If
    End Select
End Sub

Private Sub Sub_OperStatus(Str_Status As String)                 '工具条依据不同状态所进行的变化
    With Tlb_Action
        Select Case Str_Status
        Case "10"   '浏览(系统进入、放弃新增单据、填制凭证时删除单据,凭证审核)
            '工具条
            .Buttons("dy").Enabled = True      '打印
            .Buttons("yl").Enabled = True      '预览
            .Buttons("xg").Enabled = False     '修改
            .Buttons("Fill").Enabled = False     '填充
            
            .Buttons("zh").Enabled = False     '增行
            .Buttons("sh").Enabled = False     '删行
            .Buttons("cx").Enabled = True      '查询
            .Buttons("bc").Enabled = False     '保存
            .Buttons("fq").Enabled = False     '放弃
            
            '录入文本框
            For Jsqte = Max_Text_Index To 0 Step -1
                LrText(Jsqte).Enabled = False
            Next Jsqte
            CmbOut_In.Enabled = False
            
        Case "11"   '浏览(放弃修改单据,查询单据)
            '工具条
            .Buttons("dy").Enabled = True      '打印
            .Buttons("yl").Enabled = True      '预览
            .Buttons("xg").Enabled = True      '修改
            .Buttons("Fill").Enabled = False      '填充
            .Buttons("bc").Enabled = False     '保存
            .Buttons("fq").Enabled = False     '放弃
            '录入文本框
            For Jsqte = 0 To Max_Text_Index
                LrText(Jsqte).Enabled = False
            Next Jsqte
            CmbOut_In.Enabled = False
            
        Case "30"   '修改
            '工具条
            .Buttons("dy").Enabled = False      '打印
            .Buttons("yl").Enabled = False      '预览
            .Buttons("xg").Enabled = False      '修改
            .Buttons("Fill").Enabled = True       '填充
            .Buttons("bc").Enabled = True       '保存
            .Buttons("fq").Enabled = True       '放弃
            '录入文本框
            For Jsqte = 0 To Max_Text_Index
                LrText(Jsqte).Enabled = True
            Next Jsqte
            CmbOut_In.Enabled = True
            LrText(0).SetFocus
        End Select
    End With
End Sub

Private Sub Sub_EditBill()                                                '修改一张单据
    '判断当前凭证是否允许修改
    If Not Fun_AllowEdit Then
        Exit Sub
    End If
    
    '设置操作状态为修改
    Lab_OperStatus.Caption = "3"
    '设置工具条状态
    Call Sub_OperStatus("30")
End Sub

Private Function Fun_AllowEdit() As Boolean
    Fun_AllowEdit = True
End Function

Private Sub Sub_AbandonBill()                                              '放弃对当前单据的操作
    
    '先关闭录入载体
    Select Case Trim(Lab_OperStatus.Caption)
    Case "3"         '修改状态
        '重新显示当前单据
        Call Sub_ShowBill
        '设置操作状态为浏览
        Lab_OperStatus = "1"
        Call Sub_OperStatus("11")
    End Select
End Sub

Private Sub Xldqh()                                                      '显露当前行
    Dim Toprowte As Long
    With WglrGrid
        Toprowte = 0
        Do While .CellTop + .RowHeight(.Row) + Fzxwghs * Sjhgd > .Height And .TopRow <> Toprowte
            Toprowte = .TopRow
            .TopRow = .TopRow + 1
        Loop
        Toprowte = 0
        Do While .CellTop < .FixedRows * .RowHeight(0) And .TopRow <> Toprowte
            Toprowte = .TopRow
            .TopRow = .TopRow - 1
        Loop
    End With
End Sub

Private Sub GsToolbar_ButtonClick(ByVal Button As MSComctlLib.Button)   '表格格式设置(通用)
    Select Case Button.Key
    Case "bcgs"                              '保存表格格式
        Call Bcwggs(WglrGrid, GridCode, GridStr)
    Case "hfmrgs"                            '恢复默认格式
        Call Hfmrgs(WglrGrid, GridCode, GridStr)
    End Select
End Sub

Private Sub bbyl(bbylte As Boolean)                                     '打印预览(通用)
    Dim Bbzbt$, Bbxbt() As String, bbxbtzzxs() As Integer, Bbxbtgs As Integer
    Dim Bbbwh() As String, Bbbwhzzxs() As Integer, Bbbwhgs As Integer
    Bbxbtgs = 1                                  '报 表 小 标 题 行 数
    Bbbwhgs = 1                                  '报 表 表 尾 行 数
    ReDim Bbxbt(1 To Bbxbtgs)
    ReDim bbxbtzzxs(1 To Bbxbtgs)
    If Bbbwhgs <> 0 Then
        ReDim Bbbwh(1 To Bbbwhgs)
        ReDim Bbbwhzzxs(1 To Bbbwhgs)
    End If
    Bbzbt = ReportTitle
    bbxbtzzxs(1) = 0                             '报表行组织形式(0-居左 1-居中 2-居右)
    Bbxbt(1) = "转帐名称：" + Lbl_AutoAccName              '报表行组织形式(0-居左 1-居中 2-居右)
    Call Scyxsjb(WglrGrid)                               '生成报表数据
    Call Scdybb(Dyymctbl, Bbzbt, Bbxbt(), bbxbtzzxs(), Bbxbtgs, Bbbwh(), Bbbwhzzxs(), Bbbwhgs, bbylte)
    If Not bbylte Then
        Unload DY_Tybbyldy
    End If
End Sub

Private Function Sub_SaveBill() As Boolean                   '保 存 单 据
    Dim Rowjsq As Long           '网格行计数器
    Dim Coljsq As Long           '网格列计数器
    Dim Int_RowCount As Integer  '有效数据行计数器
    Dim Lrywlz As Long           '录入有误列值
    Dim Bj As Boolean           '辅助项有效标志
    '下面将对所有有效数据行进行有效性判断
    If LrText(0) = "" Then  '转帐科目必须输入
        Tsxx = "请输入损益类科目！"
        Call Xtxxts(Tsxx, 0, 4)
        LrText(0).SetFocus
        Exit Function
    End If
    If LrText(1) = "" Then  '利润科目必须输入
        Tsxx = "请输入本年利润科目！"
        Call Xtxxts(Tsxx, 0, 4)
        LrText(1).SetFocus
        Exit Function
    End If
    If LrText(2) = "" Then  '摘要必须输入
        Tsxx = "请输入摘要！"
        Call Xtxxts(Tsxx, 0, 4)
        LrText(2).SetFocus
        Exit Function
    End If
    Int_RowCount = 0
    With WglrGrid
        For Rowjsq = .FixedRows To .Rows - 1
            
            '带*号者为有效数据行
            If .TextMatrix(Rowjsq, 0) <> "*" Then
                Exit For
            Else
                Int_RowCount = Int_RowCount + 1
            End If
            
            '2.[自定义判断(补丁)
            '首先进行为空判断(固定不变)
            For Jsqte = Qslz To .Cols - 1
                If (GridInt(Jsqte, 5) = 1 And Len(Trim(.TextMatrix(Rowjsq, Jsqte))) = 0) Or (GridInt(Jsqte, 5) = 2 And Val(Trim(.TextMatrix(Yxxpdh, Jsqte))) = 0) Then
                    Tsxx = GridStr(Jsqte, 2)
                    Lrywlz = Jsqte
                    GoTo Lrcwcl
                    Exit For
                End If
            Next Jsqte
        Next Rowjsq
        If Int_RowCount = 0 Then
            Tsxx = "有效行数为零,不能存盘!"
            Call Xtxxts(Tsxx, 0, 1)
            Exit Function
        End If
    End With  '网格
    
    '如果以上有效性检查均顺利通过,则执行存盘动作
    
    On Error GoTo Swcwcl
    Cw_DataEnvi.DataConnect.BeginTrans
    
    '修改单据
    '1.删除原单据所有内容
    
    Cw_DataEnvi.DataConnect.Execute ("Delete Cwzz_AutoTranItem Where TranCode='" & Trim(Lbl_AutoAccCode.Caption) & "' and TranClass='" & TranClassCode & "'")
    If Rec_AutoAccItem.State = 1 Then Rec_AutoAccItem.Close
    Rec_AutoAccItem.Open "Select * From Cwzz_AutoTranItem Where 1=2", Cw_DataEnvi.DataConnect, adOpenDynamic, adLockPessimistic
    
    '写网格中的转出科目定义数据
    For Rowjsq = WglrGrid.FixedRows To WglrGrid.Rows - 1
        If WglrGrid.TextMatrix(Rowjsq, 0) <> "*" Then
            Exit For
        End If
        With Rec_AutoAccItem
            .AddNew
            .Fields("TranClass") = TranClassCode
            .Fields("TranCode") = Trim(Lbl_AutoAccCode.Caption)                                         '转帐编号
            .Fields("Digest") = Trim(WglrGrid.TextMatrix(Rowjsq, Sydz("001", GridStr(), Szzls)))        '摘要
            .Fields("Ccode") = Trim(WglrGrid.TextMatrix(Rowjsq, Sydz("002", GridStr(), Szzls)))         '损益科目
            .Fields("TranOri") = WglrGrid.TextMatrix(Rowjsq, Sydz("004", GridStr(), Szzls))             '转帐方向
            .Fields("TranProp") = "转出"                                                                '转帐性质
            .Fields("GetCcode") = Trim(WglrGrid.TextMatrix(Rowjsq, Sydz("002", GridStr(), Szzls)))      '本年利润科目
            .Fields("DistriProp") = 100                                                                 '若网格内该项没有填写，默认100%
            .Fields("FormulaCode") = "01"                                                               '来源数据项目,期末余额
        End With
    Next Rowjsq
    '写转入科目定义数据
    With Rec_AutoAccItem
        .AddNew
        .Fields("TranClass") = TranClassCode
        .Fields("TranCode") = Trim(Lbl_AutoAccCode.Caption)                                         '转帐编号
        .Fields("Digest") = Trim(LrText(2).Text)                                                    '摘要
        .Fields("Ccode") = Trim(LrText(1).Text)                                                     '损益科目
        If WglrGrid.TextMatrix(WglrGrid.FixedRows, Sydz("004", GridStr(), Szzls)) = "借" Then
            .Fields("TranOri") = "贷"                                                               '转帐方向
        Else
            .Fields("TranOri") = "借"                                                               '转帐方向
        End If
        .Fields("TranProp") = "转入"                                                                '转帐性质
        .Fields("GetCcode") = ""                                                                    '
        .Fields("DistriProp") = 100                                                                 '若网格内该项没有填写，默认100%
        .Fields("FormulaCode") = "05"                                                               '来源数据为对方汇总数
        .Update
    End With
    Cw_DataEnvi.DataConnect.CommitTrans
    Sub_SaveBill = True
    Tsxx = "保存完毕! "
    Call Xtxxts(Tsxx, 0, 4)
    
    '标识单据发生改动
    Bln_BillChange = True
    
    '设置操作状态为浏览
    Lab_OperStatus = "1"
    Call Sub_OperStatus("11")
    Exit Function
    
Swcwcl:
    Cw_DataEnvi.DataConnect.RollbackTrans
    Tsxx = "存盘过程中出现未知错误,程序自动恢复保存前状态!"
    Call Xtxxts(Tsxx, 0, 1)
    Exit Function
    
Lrcwcl:        '录入错误处理
    With WglrGrid
        Call Xtxxts("(第 " + Trim(Str(Int_RowCount)) + " 条记录)-" + Tsxx, 0, 1)
        changelock = True
        .Select Rowjsq, Lrywlz
        WglrGrid.SetFocus
        changelock = False
        Exit Function
    End With
    
End Function

Private Function TextYxxpd(Index As Integer) As Boolean           '文本框有效性判断
    Dim Sqlstr As String
    Dim Findrec As ADODB.Recordset
    If TextValiJudgeLock(Index) Then    '文本框内容未曾改变不进行有效性判断
        TextYxxpd = True
        Exit Function
    End If
    If Trim(LrText(Index)) = "" Then
        LrText(Index).Tag = ""
        Call WbklrCl_After(Index)
        TextValiJudgeLock(Index) = True
        TextYxxpd = True
        Exit Function
    End If
    Select Case Textint(Index, 4)
    Case 1      '编码型
        Sqlstr = Trim(Textstr(Index, 5))
        Sqlstr = Replace(Sqlstr, "@", "'" + Trim(LrText(Index).Text) + "'")
        Set Findrec = Cw_DataEnvi.DataConnect.Execute(Sqlstr)
        If Findrec.EOF Then
            Call Xtxxts(Trim(Textstr(Index, 6)), 0, 1)
            LrText(Index).SetFocus
            Exit Function
        Else
            Select Case Textint(Index, 3)
            Case 0
                If Len(Trim(Textstr(Index, 2))) <> 0 Then