VB开发的ERP系统

    Set Rec_VouchMain = Nothing
         
    '2.对单据子表进行处理
         
    '打开单据子表动态集
    If Rec_VouchSub.State = 1 Then Rec_VouchSub.Close
    Rec_VouchSub.Open "Select * From Chhs_PlanAdjustSub Where 1=2", Cw_DataEnvi.DataConnect, adOpenDynamic, adLockOptimistic
    
    '将网格中有效数据行写入单据子表
    For Rowjsq = XsGrid.FixedRows To XsGrid.Rows - 1
        
        With Rec_VouchSub
            .AddNew
            .Fields("PlanAdjustSubId") = Rowjsq - XsGrid.FixedRows + 1                           'Id号
            .Fields("PlanAdjustMainId") = NewMainId                                              '主表ID
            .Fields("Whcode") = Trim(XsGrid.TextMatrix(Rowjsq, 0))                               '仓库
            .Fields("Quan") = Val(XsGrid.TextMatrix(Rowjsq, 2)) + 0                                '数量
            .Update
        End With
        
        '期末处理差异,差额入明细帐
        If Qmclcy Then
            
            If Rec_List.State = 1 Then Rec_List.Close
            Rec_List.Open "select * from chhs_list where 1=2", Cw_DataEnvi.DataConnect, adOpenDynamic, adLockBatchOptimistic
            With Rec_List
                  .AddNew
                 .Fields("billnum") = CreatBillCode(BillCode, True, , Trim(XsGrid.TextMatrix(Rowjsq, 0)))
                 .Fields("inoutadjustmainid") = NewMainId
                 .Fields("inoutadjustsubid") = Rowjsq - XsGrid.FixedRows + 1
                 .Fields("billdate") = Xtrq
                 .Fields("chalkdate") = Xtrq
                 .Fields("kjyear") = Xtyear
                 .Fields("period") = mPeriod
                 .Fields("billcode") = BillCode
                 .Fields("maker") = Xtczy
                 .Fields("chalkitupman") = Xtczy
                 .Fields("whcode") = Trim(XsGrid.TextMatrix(Rowjsq, 0))
                 .Fields("mnumber") = Trim(LrText(1).Text)
                 .Fields("inoutadjustmainid") = NewMainId
                 .Fields("inoutadjustsubid") = Rowjsq - XsGrid.FixedRows + 1

                '存货科目
                Xtfhcs = ""
                Xtfhcsfz = ""
                Call MaccCode(Trim(.Fields("whcode")), Trim(LrText(1).Text), Trim(LrText(1).Tag))
                .Fields("mateacct") = Xtfhcs
                .Fields("diffacct") = Xtfhcsfz
                
                '对方科目
                Xtfhcs = ""
                Call DfaccCode("", "", Trim(LrText(1).Tag), Trim(LrText(1).Text))
                .Fields("dfacct") = Xtfhcs
                
                
                '现价>原价按入库单调整入帐，否则按出库单调整入帐
                If Val(LrText(4).Text) > Val(LrText(3).Text) Then
                    .Fields("inoutflag") = 1
                    .Fields("inmoney") = Val(XsGrid.TextMatrix(Rowjsq, 5))
                    .Fields("dfdiff") = Val(XsGrid.TextMatrix(Rowjsq, 5))
                Else
                    .Fields("inoutflag") = 0
                    .Fields("outmoney") = Abs((XsGrid.TextMatrix(Rowjsq, 5)))
                    .Fields("jfdiff") = Abs(Val(XsGrid.TextMatrix(Rowjsq, 5)))
                End If
                .UpdateBatch
            End With
            Set Rec_List = Nothing
            '调整总帐
            If Rec_Mate.State = 1 Then Rec_Mate.Close
            Rec_Mate.Open "select * from chhs_mate where kjyear=" & Xtyear & " and period=" & mPeriod & _
                    " and whcode='" & Trim(XsGrid.TextMatrix(Rowjsq, 0)) & "'" & _
                    " and mnumber='" & Trim(LrText(1).Text) & "'", _
                    Cw_DataEnvi.DataConnect, adOpenDynamic, adLockBatchOptimistic
            If Not Rec_Mate.EOF Then
                If Val(LrText(4).Text) > Val(LrText(3).Text) Then
                    Rec_Mate.Fields("inmoney") = Rec_Mate.Fields("inmoney") + Val(XsGrid.TextMatrix(Rowjsq, 5))
                    Rec_Mate.Fields("dfdiff") = Rec_Mate.Fields("dfdiff") + Val(XsGrid.TextMatrix(Rowjsq, 5))
                    If Rec_Mate.Fields("inquan") <> 0 Then
                        Rec_Mate.Fields("inprice") = Rec_Mate.Fields("inmoney") / Rec_Mate.Fields("inquan")
                    End If
                Else
                    Rec_Mate.Fields("outmoney") = Rec_Mate.Fields("outmoney") + Abs(Val(XsGrid.TextMatrix(Rowjsq, 5)))
                    Rec_Mate.Fields("jfdiff") = Rec_Mate.Fields("jfdiff") + Abs(Val(XsGrid.TextMatrix(Rowjsq, 5)))
                    If Rec_Mate.Fields("outquan") <> 0 Then
                        Rec_Mate.Fields("outprice") = Rec_Mate.Fields("outmoney") / Rec_Mate.Fields("outquan")
                    End If
                End If
                Rec_Mate.UpdateBatch
            End If
            Set Rec_Mate = Nothing
        End If
    Next Rowjsq
    
    '修改存货计划单价
    Cw_DataEnvi.DataConnect.Execute ("update Gy_material set planprice=" & Val(LrText(4).Text) & " where mnumber='" & Trim(LrText(1).Text) & "'")
    
    '修改收发记录表中未记帐单据的计划单价
    SqlStr = "SELECT Gy_InOutMain.InoutFlag,Gy_InOutMain.InOutMainId, Gy_InOutSub.InOutSubId," & _
        "Gy_InOutSub.FactReceiptQuan,Gy_InOutSub.FactIssueQuan, Gy_InOutSub.PlanPrice, " & _
        "Gy_InOutSub.PlanMoney,Gy_InOutMain.ChalkitupMan , Gy_InOutMain.KjYear,  " & _
        "Gy_InOutMain.Period FROM Gy_InOutMain INNER JOIN Gy_InOutSub ON " & _
        "Gy_InOutMain.InOutMainId = Gy_InOutSub.InOutMainId LEFT OUTER JOIN " & _
        "Gy_Warehouse ON Gy_InOutMain.WhCode = Gy_Warehouse.WhCode " & _
        "WHERE (Gy_Warehouse.PriceMode = '计划价法') AND Gy_InOutMain.ChalkitupMan='' " & _
        "AND Gy_InOutMain.BillCode<>'1211' AND kjYear=" & Xtyear & " and Period>=" & mPeriod & _
        "AND (Gy_InOutSub.MNumber = '" & Trim(LrText(1).Text) & "' )"
    Set Rectemp = Cw_DataEnvi.DataConnect.Execute(SqlStr)
    Do While Not Rectemp.EOF
        If Rectemp.Fields("InoutFlag") And Qmclcy Then
            SqlStr = "Update Gy_InOutSub set PlanPrice=" & Val(LrText(4).Text) & ",PlanMoney=" & Val(Rectemp.Fields("FactReceiptQuan")) * Val(LrText(4).Text) & " where InOutMainId=" & Rectemp.Fields("InOutMainId") & " and InOutSubId=" & Rectemp.Fields("InOutSubId")
        Else
            SqlStr = "Update Gy_InOutSub set PlanPrice=" & Val(LrText(4).Text) & ",PlanMoney=" & Val(Rectemp.Fields("FactIssueQuan")) * Val(LrText(4).Text) & " where InOutMainId=" & Rectemp.Fields("InOutMainId") & " and InOutSubId=" & Rectemp.Fields("InOutSubId")
        End If
        Cw_DataEnvi.DataConnect.Execute (SqlStr)
        Rectemp.MoveNext
    Loop
    
    Cw_DataEnvi.DataConnect.CommitTrans
    
    '将记录加入网格
    SqlStr = "SELECT top 1 * FROM Chhs_V_AdjustPlan order by planadjustmainid desc"
    Set Cxnrrec = Cw_DataEnvi.DataConnect.Execute(SqlStr)
    
    With CzxsGrid
        .AddItem ""
        .RowHeight(.Rows - 1) = Sjhgd
        .Select .Rows - 1, Qslz
        Call Jltcwg(Cxnrrec, .Rows - 1)
    End With
    
    Sub_SaveBill = True
    Tsxx = "单据存盘完毕!"
    Call Xtxxts(Tsxx, 0, 4)
    Call Sub_Abandon
    
    Exit Function

Swcwcl:       '数据存盘时出现错误
    Cw_DataEnvi.DataConnect.RollbackTrans
    With XsGrid
        If Err.Number = -2147217887 Then
            Tsxx = "现计划单价超出允许范围!"
            Call Xtxxts(Tsxx, 0, 1)
            Changelock = True
            LrText(4).SetFocus
            Changelock = False
            Exit Function
        Else
            Tsxx = "存盘过程中出现未知错误,程序自动恢复保存前状态!"
            Call Xtxxts(Tsxx, 0, 1)
            Exit Function
        End If
    End With

Lrcwcl:        '录入错误处理(存盘前逐行有效性判断)
    With XsGrid
        Call Xtxxts("(第 " & Trim(Str(Rowjsq - .FixedRows + 1)) & " 条单据分录)-" & Tsxx, 0, 1)
        Changelock = True
        .Select Rowjsq, Lrywlz
        XsGrid.SetFocus
        Changelock = False
        Exit Function
    End With

End Function


Private Function Cshlrxx(lrztxx As Integer, MainId As Integer) As Boolean              '初始化录入字段信息

    TextChangeLock = True       '关闭文本框Chang事件
    Dim Rectemp As Recordset
    
    If lrztxx = 1 Then
    
        '增加新记录时将文本框清空
        For Jsqte = 0 To Max_Text_Index
            If Len(Trim(Textstr(Jsqte, 1))) <> 0 Then
                LrText(Jsqte).Text = ""
                LrText(Jsqte).Tag = ""
            End If
            TextValiJudgeLock(Jsqte) = True
        Next Jsqte
       
        '[>>
        '在此处可添加新增记录时初始化设置
        '<<]
    Else
    
        '修改记录时根据记录关键字(编码)从数据表中读入其他字段内容
        
        SqlStr = "SELECT * FROM Chhs_V_AdjustPlan Where PlanAdjustMainId='" & MainId & "'"
        Set Rectemp = Cw_DataEnvi.DataConnect.Execute(SqlStr)
       
         With Rectemp
           '记录如存在则读入其内容,否则提示记录已被其他人删除
            If Not .EOF Then
                LrText(0).Text = Format(Trim(.Fields("billdate") & ""), "yyyy-mm-dd")               '日期
                LrText(1).Text = Trim(.Fields("mnumber") & "")               '存货编码
                LrText(2).Text = Trim(.Fields("mname") & "")                 '存货名称
                LrText(3).Text = .Fields("adjustbeforeprice")                '调整前计划单价
                LrText(4).Text = .Fields("adjustafterprice")                 '调整后计划单价
                LrText(5).Text = Trim(.Fields("remark") & "")                '备注
                
                '填充网格
                If Trim(.Fields("whcode")) <> "" Then
                    Do While Not .EOF
                        XsGrid.AddItem ""
                        XsGrid.RowHeight(XsGrid.Rows - 1) = Sjhgd
                        XsGrid.TextMatrix(XsGrid.Rows - 1, 0) = Trim(.Fields("whcode"))
                        XsGrid.TextMatrix(XsGrid.Rows - 1, 1) = Trim(.Fields("whname"))
                        XsGrid.TextMatrix(XsGrid.Rows - 1, 2) = Trim(.Fields("quan"))
                        XsGrid.TextMatrix(XsGrid.Rows - 1, 3) = Val(.Fields("adjustbeforeprice")) * Val(.Fields("quan"))
                        XsGrid.TextMatrix(XsGrid.Rows - 1, 4) = Val(.Fields("adjustafterprice")) * Val(.Fields("quan"))
                        XsGrid.TextMatrix(XsGrid.Rows - 1, 5) = (Val(.Fields("adjustafterprice")) - Val(.Fields("adjustbeforeprice"))) * Val(.Fields("quan"))
                        .MoveNext
                    Loop
                End If
            Else
                Tsxx = "该记录已经被其他人删除,请刷新当前数据!"
                Call Xtxxts(Tsxx, 0, 1)
                TextChangeLock = False
                Exit Function
            End If
            
        End With
        
    End If
    
    Cshlrxx = True
    TextChangeLock = False
    
End Function

Private Sub Sub_Abandon()                 '放 弃 当 前 记 录

    '清除文本框内容
    For Jsqte = LrText.count - 1 To 0 Step -1
        LrText(Jsqte).Text = ""
        TextValiJudgeLock(Jsqte) = True
    Next Jsqte
    
    '清除网格内容
    XsGrid.Rows = XsGrid.FixedRows
    
    StTab.Tab = 0
    StTab.TabEnabled(1) = False
    
    '调整工具条
    Call Toolfbjzt
    GsToolbar.Visible = True
    
End Sub

'*******************以下区域为编写自定义过程区域**********************

'*******************以上区域为编写自定义过程区域**********************

'*******************************以下为基本处理程序(固定不变)*******************************************'
Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)        '支持热键操作

    If Shift = 2 Then
        Select Case UCase(Chr(KeyCode))
            Case "P"                                                                          'Ctrl+P 打印
                If SzToolbar.Buttons("dy").Visible And SzToolbar.Buttons("dy").Enabled Then
                    Call bbyl(False)
                End If
            Case "A"                                                                          'Ctrl+A 增加
                Call Sub_Add
        End Select
    End If
  
End Sub

Private Sub SzToolbar_ButtonClick(ByVal Button As MSComctlLib.Button)

    Select Case Button.Key
        Case "ymsz"                                          '页面设置
            Dyymctbl.Show 1
        Case "yl"                                            '预 览
            Call bbyl(True)
        Case "dy"                                            '打 印
             Call bbyl(False)
        Case "cx"                                            '查 询
            DJ_AdjustPlanCond.Show 1
            Call Cxnrtcwg
            Call Toolfbjzt
        Case "Bill"                                          '单 据
           Call CzxsGrid_DblClick
        Case "zj"                                            '增 加
            Call Sub_Add
        Case "bc"                                            '保 存
            Call Sub_SaveBill
        Case "fq"                                            '放 弃
        For Jsqte = LrText.count - 1 To 0
            TextValiJudgeLock(Jsqte) = True
        Next Jsqte
            Call Sub_Abandon
        Case "sx"                                            '刷 新
            Call Cxnrtcwg
        Case "bz"                                            '帮 助
            Call F1bz
        Case "fh"                                            '退 出
            Unload Me
    End Select
    
End Sub

Private Sub Sub_Add()       '增加

    '判断用户是否有此功能执行权限,如有则写上机日志(进入)
    If Not Security_Log(Str_RightEdit, Xtczybm, 1, True) Then
        Exit Sub
    End If
    
    '单据录入日期是否在当前年度
    If Not Year(CDate(Xtrq)) = PGKjYear Then
        Tsxx = "操作日期不在当前会计年度(" + Trim(Str(PGKjYear)) + ")之内,请重新登录!"
        Call Xtxxts(Tsxx, 0, 1)
        Exit Sub
    End If
    
    '单据日期必须在当前会计期间
    If Month(Xtrq) <> PGNowmon Then
        Tsxx = "操作日期不在当前会计期间(" + Trim(Str(PGKjYear)) + "." + Trim(Str(PGNowmon)) + ")之内,请重新登录!"
        Call Xtxxts(Tsxx, 0, 1)
        Exit Sub
    End If