开通博客赚积分
发布资源赚积分
分类

源码开发语言/平台
当前位置：首页 > 源码/资料 > 行业应用 > 企业管理 > 查看源码
资源名称：ERPSYS.zip　[点击查看]
上传用户：zhpu1995
上传日期：2013-09-06
资源大小：61151k
文件大小：167k
源码类别：

企业管理

开发平台：

Visual Basic

：源码内容
  1.         '重置网格(Fixed)
  2.         With WglrGrid
  3.             .Rows = Pmbcsjhs + .FixedRows + Fzxwghs + 1
  4.             For jsqte = .FixedRows To .Rows - 1
  5.                 .RowHeight(jsqte) = Sjhgd
  6.             Next jsqte
  8.             WglrGrid.Clear 1
  9.             Changelock = True
  10.             .Select .FixedRows, Qslz
  11.             Changelock = False
  12.         End With
  14.         '计算合计数据(清零)(Fixed)
  15.         For jsqte = Qslz To WglrGrid.Cols - 1
  16.             Call Sjhj(jsqte)
  17.         Next jsqte
  18.     End If
  19.     
  20.     '设置操作状态为浏览
  21.     Lab_OperStatus = "1"
  22.     Call Sub_OperStatus("10")
  24. End Sub
  26. Private Function Sub_SaveBill() As Boolean                                   '保 存 单 据
  27.   
  28.     Dim RecTemp As New ADODB.Recordset                    '临时使用动态集
  29.     Dim Rec_VouchMain As New ADODB.Recordset              '单据主表动态集
  30.     Dim Rec_VouchSub As New ADODB.Recordset               '单据子表动态集
  31.     Dim Rec_Sub As New ADODB.Recordset
  32.     Dim Rowjsq As Long                                    '网格行计数器
  33.     Dim Coljsq As Long                                    '网格列计数器
  34.     Dim jsqte As Integer                                  '临时计数器
  35.     Dim Lng_RowCount As Long                              '有效数据行计数器
  36.     Dim Lrywlz As Long                                    '录入有误列值
  37.     Dim Int_Year As Integer                               '用户选择会计年度
  38.     Dim Int_Period As Integer                             '用户选择会计期间
  39.     Dim strMNum As String
  40.     Dim strMArea As String
  41.     Dim strBatch As String
  42.     Dim strWhCode As String
  43.     Dim dblEndQuan As Double
  44.     
  45.     Sub_SaveBill = False
  46.   
  47.     '一.============先对单据内容进行有效性判断==============='
  48.   
  49.     '先进行字段不能为空或不能为零有效性判断(Fixed)
  50.     For jsqte = 0 To Max_Text_Index
  51.         If Textint(jsqte, 8) = 1 Then     '字段不能为空
  52.             If Len(Trim(LrText(jsqte).Text)) = 0 Then
  53.                 Tsxx = Textstr(jsqte, 7) & "不能为空!"
  54.                 Call Xtxxts(Tsxx, 0, 1)
  55.                 If jsqte = 2 Then
  56.                     Exit Function
  57.                 End If
  58.                 LrText(jsqte).SetFocus
  59.                 Exit Function
  60.             End If
  61.         Else
  62.             If Textint(jsqte, 8) = 2 Then   '字段不能为零
  63.                 If Val(Trim(LrText(jsqte).Text)) = 0 Then
  64.                     Tsxx = Textstr(jsqte, 7) & "不能为零!"
  65.                     Call Xtxxts(Tsxx, 0, 1)
  66.                     LrText(jsqte).SetFocus
  67.                     Exit Function
  68.                 End If
  69.             End If
  70.         End If
  71.     Next jsqte
  72.     
  73.     '对需要进行事后判断的文本框录入内容进行有效性判断 (Fixed)
  74.     For jsqte = 0 To Max_Text_Index
  75.         If Textint(jsqte, 9) = 0 Or Textint(jsqte, 9) = 2 Then
  76.             If Not TextYxxpd(jsqte) Then
  77.                 Call TextShow(jsqte)
  78.                 Exit Function
  79.             End If
  80.         End If
  81.     Next jsqte
  82.   
  83.     '[>>
  84.   
  85.     '可在此区域写入其他对单据表头内容的有效性判断.
  86.     
  87.     '[判断用户所选会计期间是否有效(非结帐月份),且制单日期必须和所选会计期间一致
  88.     If CheckBillDate(LrText(4), Int_Year, Int_Period) = True Then
  89.         Exit Function
  90.     End If
  91.     
  92.     Dim strSQLTemp As String
  93.     Dim adoRec As New ADODB.Recordset
  94.     Dim strSQL As String
  95.     Dim adoRecTemp As New ADODB.Recordset
  96.     
  97.     strSQLTemp = "SELECT MAX(Period) AS MaxPeriod FROM GY_kjrlb WHERE kfjzbz=1 AND kjyear in (select max(kjyear) from gy_kjrlb)"
  98.     Set adoRec = Cw_DataEnvi.DataConnect.Execute(strSQLTemp)
  99.     With adoRec
  100.         If Not .EOF Then
  101.             If Not IsNull(.Fields("MaxPeriod")) Then
  102.                 If .Fields("MaxPeriod") = 12 Then
  103.                     TempPeriod = 0
  104.                 Else
  105.                     TempPeriod = .Fields("MaxPeriod")
  106.                 End If
  107.             Else
  108.                 TempPeriod = 0
  109.             End If
  110.         End If
  111.     End With
  112.     adoRec.Close
  113.     Set adoRec = Nothing
  114.     strSQL = "SELECT * FROM GY_WareHouse WHERE WhCode='" & Trim(LrText(1).Tag) & "'"
  115.     Set adoRecTemp = Cw_DataEnvi.DataConnect.Execute(strSQL)
  116.     With adoRecTemp
  117.         If Not .EOF Then
  118.             If Month(CDate(LrText(4).Text)) = TempPeriod + 1 Then
  119.                 If .Fields("EndDealFlagWh") Then
  120.                     Tsxx = "本仓库在所选会计期间已经结帐,不能再填制单据!"
  121.                     Call Xtxxts(Tsxx, 0, 4)
  122.                     Exit Function
  123.                 End If
  124.             End If
  125.         End If
  126.     End With
  127.     adoRecTemp.Close
  128.     Set adoRecTemp = Nothing
  129.     
  130.     '<<]
  131.   
  132.     '[>>下面将对所有有效数据行进行有效性判断
  133.   
  134.     Lng_RowCount = 0
  135.   
  136.     With WglrGrid
  137.         For Rowjsq = .FixedRows To .Rows - 1
  138.             '带*号者为有效数据行(Fixed)
  139.             If .TextMatrix(Rowjsq, 0) <> "*" Then
  140.                 Exit For
  141.             Else
  142.                 Lng_RowCount = Lng_RowCount + 1
  143.             End If
  144.             '1.首先进行为空或为零判断(Fixed)
  145.     '1.首先进行为空或为零判断(Fixed)
  147.             For jsqte = Qslz To .Cols - 1
  148.                 '字段不能为空
  149.                 If GridInt(jsqte, 5) = 1 Then
  150.                     If Len(Trim(.TextMatrix(Rowjsq, jsqte))) = 0 Then
  151.                         Tsxx = GridStr(jsqte, 2)
  152.                         Lrywlz = jsqte
  153.                         GoTo Lrcwcl
  154.                         Exit For
  155.                     End If
  156.                 End If
  157.                 
  158.                 '字段不能为零
  159.                 If GridInt(jsqte, 5) = 2 Then
  160.                     If Val(Trim(.TextMatrix(Rowjsq, jsqte))) = 0 Then
  161.                         Tsxx = GridStr(jsqte, 2)
  162.                         Lrywlz = jsqte
  163.                         GoTo Lrcwcl
  164.                         Exit For
  165.                     End If
  166.                 End If
  167.             Next jsqte
  168.             
  169.             '2.对于设置了批次和保值期管理的物料,进行相应的判断
  170.             If conArea = 1 Then
  171.                 If CBool(.ColHidden(Sydz("005", GridStr(), Szzls))) = False Then
  172.                     If .TextMatrix(Rowjsq, Sydz("005", GridStr(), Szzls)) = "" Then
  173.                         Tsxx = "仓库设置为货区管理,货区不能为空!"
  174.                         Lrywlz = Sydz("005", GridStr(), Szzls)
  175.                         GoTo Lrcwcl
  176.                         Exit For
  177.                     End If
  178.                 End If
  179.             End If
  180.             If conBatch = 1 Then
  181.                 If CBool(WglrGrid.TextMatrix(Rowjsq, 2)) = True Then
  182.                     If .TextMatrix(Rowjsq, Sydz("006", GridStr(), Szzls)) = "" Then
  183.                         Tsxx = "物料设置为批次管理,批号不能为空!"
  184.                         Lrywlz = Sydz("006", GridStr(), Szzls)
  185.                         GoTo Lrcwcl
  186.                         Exit For
  187.                     End If
  188.                 End If
  189.             End If
  190.         Next Rowjsq
  191.      
  192.         '单据分录行数不能为零(Fixed)
  193.         If Lng_RowCount = 0 Then
  194.             Tsxx = "单据分录行数不能为零!"
  195.             Call Xtxxts(Tsxx, 0, 1)
  196.             Exit Function
  197.         End If
  198.         
  199.         '[>>
  200.         '此处可以定义整张单据不能通过有效性检查的理由
  201.         '<<]
  202.     End With  '网格
  203.    
  204.    
  205.     '二.=============如果以上有效性检查均顺利通过,则执行存盘动作============'
  206.    
  207.     '对存盘进行事务处理(Fixed)
  208.     On Error GoTo Swcwcl
  209.     Cw_DataEnvi.DataConnect.BeginTrans
  210.     
  211.     '判断单据状态以进行不同处理
  212.     
  213.     '1.先对单据主表进行处理
  214.     If Trim(Lab_OperStatus) = "2" Then
  215.     
  216.         '新增单据
  217.         
  218.         '1.对于某些单据号自动生成的单据则可在此处自动生成
  219.         LrText(2).Text = CreatBillCode(BillCode, True, Xtyear, Xtmm, Trim(LrText(1).Tag))
  220.     
  221.         '2.开始存盘
  222.          
  223.         '打开单据主表动态集
  224.         If Rec_VouchMain.State = 1 Then Rec_VouchMain.Close
  225.         Rec_VouchMain.Open "Select * From Gy_InOutMain Where 1=2", Cw_DataEnvi.DataConnect, adOpenDynamic, adLockOptimistic
  226.              
  227.         With Rec_VouchMain
  228.             .AddNew
  229.             .Fields("InOutMainID") = CreatBillID(BillCode)                                              '单据ID
  230.             .Fields("BillCode") = "1205"                                                                '单据编码
  231.             .Fields("kjYear") = Int_Year                                                                '会计年度
  232.             .Fields("Period") = Int_Period                                                              '会计期间
  233.             .Fields("OperType") = "销售出库"
  234.             .Fields("InOutFlag") = 0                                                                    '收发标志
  235.             .Fields("BillDate") = CDate(LrText(4).Text)                                                 '订单日期
  236.             .Fields("BillNum") = Trim(LrText(2).Text)                                                   '单据号
  237.             .Fields("WhCode") = Trim(LrText(1).Tag)                                                     '仓库编码
  238.             If Trim(LrText(0).Text) <> "" Then
  239.                 .Fields("ConsignBillNum") = Trim(LrText(0).Text)                                        '发货单号
  240.                 .Fields("ConsignBillID") = Trim(LrText(0).Tag)                                          '发货单ID
  241.             End If
  242.             If Trim(LrText(3).Tag) <> "" Then
  243.                 .Fields("CusCode") = Trim(LrText(3).Tag)                                                '客户编码
  244.             End If
  245.             If Trim(LrText(5).Tag) <> "" Then
  246.                 .Fields("InOutClassCode") = Trim(LrText(5).Tag)                                         '收发类别
  247.             End If
  248.             If Trim(LrText(6).Tag) <> "" Then
  249.                 .Fields("DeptCode") = Trim(LrText(6).Tag)                                               '部门编码
  250.             End If
  251.             If Trim(LrText(7).Tag) <> "" Then
  252.                 .Fields("TransferWayCode") = Trim(LrText(7).Tag)                                        '运输方式
  253.             End If
  254.             If Trim(LrText(8).Tag) <> "" Then
  255.                 .Fields("TranCompanyCode") = Trim(LrText(8).Tag)                                        '运输单位
  256.             End If
  257.             If Trim(LrText(9).Text) <> "" Then
  258.                 .Fields("BusNum") = Trim(LrText(9).Text)                                                '车号
  259.             End If
  261.             .Fields("Remark") = Trim(LrText(10).Text)                                                   '备注
  262.             .Fields("Maker") = Xtczy                                                                    '制单人
  263.             .Fields("KFChecker") = ""                                                                   '审核人置空
  264.             If OptRed.Value = True Then
  265.                 .Fields("RedBlueFlag") = 1
  266.                 RBFlag = 1
  267.             Else
  268.                 .Fields("RedBlueFlag") = 0
  269.                 RBFlag = 0
  270.             End If
  271.             .Update
  272.             '系统读出单据ID写入Lab_BillID
  273.             Lab_BillId.Caption = .Fields("InOutMainID")
  274.         End With
  275.     Else
  276.         '修改单据
  277.         Set Rec_Sub = Cw_DataEnvi.DataConnect.Execute("select mnumber,marea,batchnum,factIssueQuan from Gy_inoutSub where InoutMainId=" & Val(Lab_BillId.Caption))
  278.         With Rec_Sub
  279.             If Not .EOF Then
  280.                 .MoveFirst
  281.                 For LsJs = 1 To .RecordCount
  282.                     If IsNull(.Fields("marea")) Then
  283.                         StrTemp1 = ""
  284.                     Else
  285.                         StrTemp1 = Trim(.Fields("marea"))
  286.                     End If
  287.                     '1修改现存量
  288.                     Cw_DataEnvi.DataConnect.Execute (" KF_SP_ChangeQuan '" & Trim(LrText(1).Tag) & "','" & StrTemp1 & "','" & Trim(.Fields("mnumber")) & "','" & Trim(.Fields("batchnum")) & "'," & Val(.Fields("factIssueQuan")) & ",0")
  289.                     '2修改物料表
  290.                     Cw_DataEnvi.DataConnect.Execute ("Update gy_material set NowStorage=NowStorage+(" & Val(.Fields("factIssueQuan")) & ") where mNumber='" & Trim(.Fields("mnumber")) & "'")
  291.                     '3修改到货数量
  292.                     If Val(LrText(0).Tag) <> 0 Then
  293.                         Cw_DataEnvi.DataConnect.Execute ("Update Xs_ConsignBillSub set EmergeQuantity=EmergeQuantity-(" & KFChangeXS(.Fields("factIssueQuan"), Trim(.Fields("mnumber")), 1) & ") where WareCode='" & Trim(.Fields("mnumber")) & "' and ConsignBillMainId=" & Val(LrText(0).Tag))
  294.                     End If
  295.                     '4修改已出库数量?
  296.                     If Trim(.Fields("batchnum") & "") <> "" Then
  297.                         If BatchJudge(Trim(LrText(1).Tag), Trim(.Fields("mnumber")), Trim(.Fields("batchnum")), intCount, intFatherID(), intChildID(), IsQc(), True) = 0 Then
  298.                             Call RestoreQuan(intCount, intFatherID(), intChildID(), IsQc(), .Fields("factissuequan"), True)
  299.                         End If
  300.                     End If
  301.                     .MoveNext
  302.                 Next LsJs
  303.             End If
  304.         End With
  305.             
  306.         '1.删除原单据子表中所有内容
  307.         Cw_DataEnvi.DataConnect.Execute ("Delete Gy_InoutSub Where InOutMainID=" & Val(Lab_BillId.Caption))
  308.         
  309.         '打开单据主表动态集
  310.         If Rec_VouchMain.State = 1 Then Rec_VouchMain.Close
  311.         Rec_VouchMain.Open "Select * From Gy_InOutMain  Where InOutMainID=" & Val(Lab_BillId.Caption), Cw_DataEnvi.DataConnect, adOpenDynamic, adLockOptimistic
  312.         With Rec_VouchMain
  313.             .Fields("kjYear") = Int_Year                                                                '会计年度
  314.             .Fields("Period") = Int_Period                                                              '会计期间
  315.             .Fields("OperType") = "销售出库"
  316.             .Fields("InOutFlag") = 0                                                                    '收发标志
  317.             .Fields("BillDate") = CDate(LrText(4).Text)                                                 '订单日期
  318.             .Fields("BillNum") = Trim(LrText(2).Text)                                                   '单据号
  319.             .Fields("WhCode") = Trim(LrText(1).Tag)                                                     '仓库编码
  320.             If Trim(LrText(0).Text) <> "" Then
  321.                 .Fields("ConsignBillNum") = Trim(LrText(0).Text)                                        '发货单号
  322.                 .Fields("ConsignBillID") = Trim(LrText(0).Tag)                                          '发货单ID
  323.             Else
  324.                 .Fields("ConsignBillNum") = Null                                                        '发货单号
  325.                 .Fields("ConsignBillID") = Null                                                         '发货单ID
  326.             End If
  327.             If Trim(LrText(3).Tag) <> "" Then
  328.                 .Fields("CusCode") = Trim(LrText(3).Tag)                                                '客户编码
  329.             Else
  330.                 .Fields("CusCode") = Null
  331.             End If
  332.             If Trim(LrText(5).Tag) <> "" Then
  333.                 .Fields("InOutClassCode") = Trim(LrText(5).Tag)                                         '收发类别
  334.             Else
  335.                 .Fields("InOutClassCode") = Null
  336.             End If
  337.             If Trim(LrText(6).Tag) <> "" Then
  338.                 .Fields("DeptCode") = Trim(LrText(6).Tag)                                               '部门编码
  339.             Else
  340.                 .Fields("DeptCode") = Null
  341.             End If
  342.             If Trim(LrText(7).Tag) <> "" Then
  343.                 .Fields("TransferWayCode") = Trim(LrText(7).Tag)                                        '运输方式
  344.             Else
  345.                 .Fields("TransferWayCode") = Null
  346.             End If
  347.             If Trim(LrText(8).Tag) <> "" Then
  348.                 .Fields("TranCompanyCode") = Trim(LrText(8).Tag)                                        '运输单位
  349.             Else
  350.                 .Fields("TranCompanyCode") = Null
  351.             End If
  352.             If Trim(LrText(9).Text) <> "" Then
  353.                 .Fields("BusNum") = Trim(LrText(9).Text)                                                '车号
  354.             End If
  356.             .Fields("Remark") = Trim(LrText(10).Text)                                                   '备注
  357.             .Fields("Maker") = Xtczy                                                                    '制单人
  358.             .Fields("KFChecker") = ""                                                                   '审核人置空
  359.             If OptRed.Value = True Then
  360.                 .Fields("RedBlueFlag") = 1
  361.                 RBFlag = 1
  362.             Else
  363.                 .Fields("RedBlueFlag") = 0
  364.                 RBFlag = 0
  365.             End If
  366.             .Update
  367.         End With
  368.         
  369.     End If
  370.          
  371.     '2.对单据子表进行处理
  372.          
  373.     '打开单据子表动态集
  374.     If Rec_VouchSub.State = 1 Then Rec_VouchSub.Close
  375.     Rec_VouchSub.Open "Select * From Gy_InoutSub Where 1=2", Cw_DataEnvi.DataConnect, adOpenDynamic, adLockOptimistic
  376.      
  377.     '将网格中有效数据行写入单据子表
  378.     For Rowjsq = WglrGrid.FixedRows To WglrGrid.Rows - 1
  379.         If WglrGrid.TextMatrix(Rowjsq, 0) <> "*" Then
  380.             Exit For
  381.         End If
  382.         
  383.         With Rec_VouchSub
  384.             .AddNew
  385.             
  386.             .Fields("InOutSubID") = Rowjsq - WglrGrid.FixedRows + 1                                                     '单据记录顺序号
  387.             .Fields("InOutMainID") = Val(Lab_BillId.Caption)                                                            '单据ID
  388.             .Fields("MNumber") = Trim(WglrGrid.TextMatrix(Rowjsq, Sydz("001", GridStr(), Szzls)))                       '物料编码
  389.             If Trim(WglrGrid.TextMatrix(Rowjsq, Sydz("005", GridStr(), Szzls))) <> "" Then
  390.                 .Fields("MArea") = Trim(WglrGrid.TextMatrix(Rowjsq, 1))                                                 '货区
  391.             End If
  392.             If Trim(WglrGrid.TextMatrix(Rowjsq, Sydz("006", GridStr(), Szzls))) <> "" Then
  393.                 .Fields("BatchNum") = Trim(WglrGrid.TextMatrix(Rowjsq, Sydz("006", GridStr(), Szzls)))                  '批号
  394.             End If
  395.             .Fields("Price") = Val(WglrGrid.TextMatrix(Rowjsq, Sydz("008", GridStr(), Szzls)))                          '单价
  396.             If OptRed.Value = True Then
  397.                 .Fields("IssueMoney") = 0 - Val(WglrGrid.TextMatrix(Rowjsq, Sydz("009", GridStr(), Szzls)))             '金额
  398.                 If WglrGrid.ColHidden(Sydz("013", GridStr(), Szzls)) = False Then
  399.                     If Val(WglrGrid.TextMatrix(Rowjsq, Sydz("013", GridStr(), Szzls))) <> 0 Then
  400.                         .Fields("PlanMoney") = 0 - Val(WglrGrid.TextMatrix(Rowjsq, Sydz("013", GridStr(), Szzls)))      '计划金额
  401.                     End If
  402.                 End If
  403.             Else
  404.                 .Fields("IssueMoney") = Val(WglrGrid.TextMatrix(Rowjsq, Sydz("009", GridStr(), Szzls)))                 '金额
  405.                 If WglrGrid.ColHidden(Sydz("013", GridStr(), Szzls)) = False Then
  406.                     If Val(WglrGrid.TextMatrix(Rowjsq, Sydz("013", GridStr(), Szzls))) <> 0 Then
  407.                         .Fields("PlanMoney") = Val(WglrGrid.TextMatrix(Rowjsq, Sydz("013", GridStr(), Szzls)))          '计划金额
  408.                     End If
  409.                 End If
  410.             End If
  411.             If OptRed.Value = True Then
  412.                 .Fields("factIssueQuan") = 0 - Val(WglrGrid.TextMatrix(Rowjsq, Sydz("011", GridStr(), Szzls)))          '数量
  413.                 If Val(WglrGrid.TextMatrix(Rowjsq, Sydz("007", GridStr(), Szzls))) <> 0 Then
  414.                     .Fields("QuanIssue") = 0 - Val(WglrGrid.TextMatrix(Rowjsq, Sydz("007", GridStr(), Szzls)))          '数量
  415.                 End If
  416.             Else
  417.                 If Val(WglrGrid.TextMatrix(Rowjsq, Sydz("007", GridStr(), Szzls))) <> 0 Then
  418.                     .Fields("QuanIssue") = Val(WglrGrid.TextMatrix(Rowjsq, Sydz("007", GridStr(), Szzls)))              '数量
  419.                 End If
  420.                 .Fields("factIssueQuan") = Val(WglrGrid.TextMatrix(Rowjsq, Sydz("011", GridStr(), Szzls)))              '数量
  421.             End If
  422.             If Trim(WglrGrid.TextMatrix(Rowjsq, Sydz("010", GridStr(), Szzls))) <> "" Then
  423.                 .Fields("InvalidDate") = CDate(Trim(WglrGrid.TextMatrix(Rowjsq, Sydz("010", GridStr(), Szzls))))        '失效日期
  424.             End If
  425.             If WglrGrid.ColHidden(Sydz("012", GridStr(), Szzls)) = False Then
  426.                 If Val(WglrGrid.TextMatrix(Rowjsq, Sydz("012", GridStr(), Szzls))) <> 0 Then
  427.                     .Fields("PlanPrice") = Val(WglrGrid.TextMatrix(Rowjsq, Sydz("012", GridStr(), Szzls)))              '计划单价
  428.                 End If
  429.             End If
  430.             .Update
  431.         End With
  432.         
  433.         '修改现存量
  434.         strWhCode = Trim(LrText(1).Tag)
  435.         strMArea = Trim(WglrGrid.TextMatrix(Rowjsq, 1) & "")
  436.         strMNum = Trim(WglrGrid.TextMatrix(Rowjsq, Sydz("001", GridStr(), Szzls)))
  437.         strBatch = Trim(WglrGrid.TextMatrix(Rowjsq, Sydz("006", GridStr(), Szzls)) & "")
  438.         If OptRed.Value = True Then
  439.             dblEndQuan = 0 - Val(WglrGrid.TextMatrix(Rowjsq, Sydz("011", GridStr(), Szzls)))
  440.         Else
  441.             dblEndQuan = Val(WglrGrid.TextMatrix(Rowjsq, Sydz("011", GridStr(), Szzls)))
  442.         End If
  443.         Cw_DataEnvi.DataConnect.Execute (" KF_SP_ChangeQuan '" & strWhCode & "','" & strMArea & "','" & strMNum & "','" & strBatch & "'," & dblEndQuan & ",1")
  444.         '修改物料表
  445.         Cw_DataEnvi.DataConnect.Execute ("Update gy_material set NowStorage=NowStorage-(" & dblEndQuan & ") where mNumber='" & strMNum & "'")
  446.         '回填批次所对应的出库数量
  447.         If strBatch <> "" Then
  448.             If BatchJudge(Trim(LrText(1).Tag), strMNum, strBatch, intCount, intFatherID(), intChildID(), IsQc(), False) = 0 Then
  449.                 Call RestoreQuan(intCount, intFatherID(), intChildID(), IsQc(), dblEndQuan, False)
  450.             End If
  451.         End If
  452.         '如果领料申请出库，回写领料申请单
  453.         If Val(LrText(0).Tag) <> 0 Then
  454.             Cw_DataEnvi.DataConnect.Execute ("Update Xs_ConsignBillSub set EmergeQuantity=EmergeQuantity+(" & KFChangeXS(dblEndQuan, strMNum, 1) & ") where WareCode='" & strMNum & "'and ConsignBillMainId=" & Val(LrText(0).Tag))
  455.         End If
  456.         
  457.     Next Rowjsq
  458.     Cw_DataEnvi.DataConnect.CommitTrans
  459.     
  460.     Sub_SaveBill = True
  461.     Tsxx = "单据存盘完毕! 单据号:" & Trim(LrText(2).Text)
  462.     Call Xtxxts(Tsxx, 0, 4)
  463.     
  464.     '标识单据发生改动
  465.     Bln_BillChange = True
  466.     
  467.     '设置单据改变后的状态
  468.     Lab_OperStatus = "1"
  469.     Call Sub_OperStatus("10")
  470.     Rec_Query.Requery
  471.     Rec_Query.Find "InOutMainID=" & Val(Lab_BillId.Caption)
  472.     
  473.     Exit Function
  475. Swcwcl:       '数据存盘时出现错误
  476.     Cw_DataEnvi.DataConnect.RollbackTrans
  477.     With WglrGrid
  478.         If Err.Number = -2147217887 Then
  479.             Tsxx = "单据中第  " & Trim(str(Rowjsq - .FixedRows + 1)) & " 行分录录入数据超出允许范围!"
  480.             Call Xtxxts(Tsxx, 0, 1)
  481.             Changelock = True
  482.             .Select Rowjsq, Qslz
  483.             WglrGrid.SetFocus
  484.             Changelock = False
  485.             Exit Function
  486.         Else
  487.             Tsxx = "存盘过程中出现未知错误,程序自动恢复保存前状态!"
  488.             Call Xtxxts(Tsxx, 0, 1)
  489.             Exit Function
  490.         End If
  491.     End With
  493. Lrcwcl:        '录入错误处理(存盘前逐行有效性判断)
  494.     With WglrGrid
  495.         Call Xtxxts("(第 " & Trim(str(Rowjsq - .FixedRows + 1)) & " 行分录)-" & Tsxx, 0, 1)
  496.         Changelock = True
  497.         .Select Rowjsq, Lrywlz
  498.         WglrGrid.SetFocus
  499.         Changelock = False
  500.         Exit Function
  501.     End With
  503. End Function
  505. '选择首张,上张,下张,末张(此4个过程只需用您的单据ID字段名替换"InOutMainID"即可)
  506. Private Sub Sub_First()             '首 张
  507.     
  508.     With Rec_Query
  509.         If .RecordCount = 0 Then
  510.             Exit Sub
  511.         End If
  512.         .MoveFirst
  513.         Lab_BillId.Caption = .Fields("InOutMainID")
  514.         Call Sub_ShowBill
  515.     End With
  517. End Sub
  519. Private Sub Sub_Prev()             '上 张
  520.     
  521.     With Rec_Query
  522.         If .RecordCount = 0 Then
  523.             Exit Sub
  524.         End If
  525.         If Not .BOF Then
  526.             .MovePrevious
  527.         End If
  528.         If Not .BOF Then
  529.             Lab_BillId.Caption = .Fields("InOutMainID")
  530.         Else
  531.             .MoveNext
  532.         End If
  533.         Call Sub_ShowBill
  534.     End With
  536. End Sub
  538. Private Sub Sub_next()             '下 张
  539.     With Rec_Query
  540.         If .RecordCount = 0 Then
  541.             Exit Sub
  542.         End If
  543.         If Not .EOF Then
  544.             .MoveNext
  545.         End If
  546.         If Not .EOF Then
  547.             Lab_BillId.Caption = .Fields("InOutMainID")
  548.         Else
  549.             .MovePrevious
  550.         End If
  551.         Call Sub_ShowBill
  552.     End With
  554. End Sub
  556. Private Sub Sub_Last()              '末 张
  557.     
  558.     With Rec_Query
  559.         If .RecordCount = 0 Then
  560.             Exit Sub
  561.         End If
  562.         .MoveLast
  563.         Lab_BillId.Caption = .Fields("InOutMainID")
  564.         Call Sub_ShowBill
  565.     End With
  567. End Sub
  568.     
  569. '[>>===================以下为根据实际业务需要自定义过程区域=============================<<]
  571. '审核,弃审
  572. Private Sub Sub_CheckBill()             '审 核
  573.     
  574.     '[>>
  575.     '此处可以写入禁止单据审核的理由
  576.     '<<]
  577.      '判断用户是否有此功能执行权限,如有则写上机日志(进入)
  578.      If Not Security_Log(Str_RightCheck, Xtczybm, 1, True) Then
  579.         Exit Sub
  580.      End If
  581.     '将单据写入审核标识
  582.     Cw_DataEnvi.DataConnect.Execute ("Update Gy_InOutMain Set KFChecker='" & Xtczy & "' Where InOutMainID=" & Val(Lab_BillId.Caption))
  583.     
  584.     '写入系统操作员
  585.     LrText(12).Text = Xtczy
  586.     
  587.     '设置审核弃审按钮状态
  588.     Call Sub_CheckStatus
  589.     
  590.     '标识单据发生变化
  591.     Bln_BillChange = True
  593. End Sub
  595. Private Sub Sub_AbandonCheck()          '弃 审
  596.     
  597.     '[>>
  598.     '此处可以写入禁止单据弃审的理由
  599.     '<<]
  600.      '判断用户是否有此功能执行权限,如有则写上机日志(进入)
  601.      If Not Security_Log(Str_RightCheck, Xtczybm, 1, True) Then
  602.         Exit Sub
  603.      End If
  604.     '将单据清除审核标识
  605.     Cw_DataEnvi.DataConnect.Execute ("Update Gy_InOutMain Set KFChecker='' Where InOutMainID=" & Val(Lab_BillId.Caption))
  606.     
  607.     '清空单据审核人
  608.     LrText(12).Text = ""
  609.     
  610.     '设置审核弃审按钮状态
  611.     Call Sub_CheckStatus
  612.     
  613.     '标识单据发生变化
  614.     Bln_BillChange = True
  615.   
  616. End Sub
  617. Private Function Fun_AllowDel() As Boolean
  618.     Dim RecTemp As New ADODB.Recordset     '临时使用动态集
  619.     Fun_AllowDel = False
  620.     Sqlstr = "Select useFlag From KF_Operation Where operationName='" & Trim(LrText(3).Text) & "'"
  621.     Set RecTemp = Cw_DataEnvi.DataConnect.Execute(Sqlstr)
  622.     With RecTemp
  623.         If Not .EOF Then
  624.             If CBool(.Fields("UseFlag")) = True Then
  625.                 Tsxx = "该单据由系统生成,不允许修改或删除!"
  626.                 Call Xtxxts(Tsxx, 0, 4)
  627.                 Exit Function
  628.             End If
  629.         End If
  630.     End With
  631.     Fun_AllowDel = True
  633. End Function
  635. Private Function Fun_AllowEdit() As Boolean                      '判断当前单据是否允许编辑或删除
  636.   
  637.     Dim RecTemp As New ADODB.Recordset     '临时使用动态集
  638.     Fun_AllowEdit = False
  639.     Sqlstr = "Select KFChecker,ChalkitupMan,CheckFlag From Gy_InOutMain Where InOutMainID=" & Val(Lab_BillId.Caption)
  640.     Set RecTemp = Cw_DataEnvi.DataConnect.Execute(Sqlstr)
  641.     With RecTemp
  642.         If Not .EOF Then
  643.             If Trim(.Fields("KFChecker") & "") <> "" Then
  644.                 Tsxx = "该单据已审核确认,不能修改或删除!"
  645.                 Call Xtxxts(Tsxx, 0, 4)
  646.                 Exit Function
  647.             End If
  648.             If CBool(.Fields("CheckFlag")) = True Then
  649.                 Tsxx = "该单据已结帐,不能修改或删除!"
  650.                 Call Xtxxts(Tsxx, 0, 4)
  651.                 Exit Function
  652.             End If
  653.             If Trim(.Fields("ChalkitupMan") & "") <> "" Then
  654.                 Tsxx = "该单据在物料核算系统已经记帐,不能修改或删除!"
  655.                 Call Xtxxts(Tsxx, 0, 4)
  656.                 Exit Function
  657.             End If
  658.         End If
  659.     End With
  660.     Fun_AllowEdit = True
  662. End Function
  663. '[>>===================以上为根据实际业务需要自定义过程区域=============================<<]
  665. '===================以 下 程 序 为 通 用 部 分 ,一 般 不 需 更 改(程序动作部分)======================='
  666. Private Sub Sub_AdjustGrid()
  667.   
  668.     '调 整 网 格
  669.     With WglrGrid
  670.         '加 1 保持一行录入行
  671.         If .Rows < Pmbcsjhs + .FixedRows + Fzxwghs + 1 Then
  672.             .Rows = Pmbcsjhs + .FixedRows + Fzxwghs + 1
  673.             For jsqte = .FixedRows To .Rows - 1
  674.                 .RowHeight(jsqte) = Sjhgd
  675.             Next jsqte
  676.         End If
  677.         
  678.         '判断是否有辅助行和录入行,如没有则加行
  679.         Do While .TextMatrix(.Rows - 1 - Fzxwghs, 0) = "*"
  680.             .AddItem ""
  681.             .RowHeight(.Rows - 1) = Sjhgd
  682.         Loop
  683.     
  684.     End With
  686. End Sub
  688. Private Sub Lrzdbz()                                                      '录入字段帮助
  689.     
  690.     If Not Ydcommand.Visible Then
  691.         Exit Sub
  692.     End If
  693.    
  694.     With WglrGrid
  695.         Valilock = True
  696.     
  697.         '处理通用部分
  698.         Changelock = True        '调入另外窗体必须加锁
  699.         If GridInt(.Col, 6) <> 1 Then
  700.             strHlpR = FunHlpR(Trim(GridStr(.Col, 3)), "whcode", Trim(LrText(1).Tag))
  701.         End If
  702.         If UCase(GridStr(.Col, 3)) = UCase("KF_BatchHelp") Then
  703.             Call Drbmhelp(GridInt(.Col, 6), GridStr(.Col, 3), Trim(.TextMatrix(.Row, Sydz("001", GridStr(), Szzls))))
  704.         Else
  705.             Call Drbmhelp(GridInt(.Col, 6), GridStr(.Col, 3), Trim(Ydtext.Text))
  706.         End If
  707.         strHlpR = ""
  708.         Changelock = False
  709.         
  710.         If Len(Xtfhcs) <> 0 Then
  711.             If GridInt(.Col, 7) = 0 Then
  712.                 Ydtext.Text = Xtfhcs
  713.             Else
  714.                 Ydtext.Text = Xtfhcsfz
  715.             End If
  716.         End If
  717.         
  718.         Valilock = False
  719.         If Ydtext.Visible Then
  720.             Ydtext.SetFocus
  721.         End If
  722.     End With
  724. End Sub
  726. Private Sub Cshhjwg()                                                     '初始化合计网格(*对合计网格来说,录入网格为容器)
  727.     
  728.     With HjGrid
  729.     
  730.        '是否显示合计网格
  731.        If Not Sfxshjwg Then
  732.            .Visible = False
  733.            Exit Sub
  734.        Else
  735.            .Visible = True
  736.        End If
  737.       
  738.        '设置网格相关属性
  739.        .Enabled = False
  740.        .Appearance = flexFlat
  741.        .BorderStyle = flexBorderNone
  742.        .ScrollBars = flexScrollBarNone
  743.        .Width = WglrGrid.Width
  744.        .FixedRows = 0
  745.        .Rows = 1
  746.        .Cols = WglrGrid.Cols
  747.        .LeftCol = WglrGrid.LeftCol
  748.        .TextMatrix(0, Qslz) = "合  计"
  749.        For jsqte = 0 To WglrGrid.Cols - 1
  750.            .ColHidden(jsqte) = WglrGrid.ColHidden(jsqte)
  751.            .ColWidth(jsqte) = WglrGrid.ColWidth(jsqte)
  752.            .ColAlignment(jsqte) = WglrGrid.ColAlignment(jsqte)
  753.            .ColFormat(jsqte) = WglrGrid.ColFormat(jsqte)
  754.        Next jsqte
  755.        .ColAlignment(Qslz) = flexAlignCenterTop
  756.        For jsqte = .FixedRows To .Rows - 1
  757.            .RowHeight(jsqte) = .Height / .Rows
  758.        Next jsqte
  759.        
  760.       '程序自动调整网格高度(自动设置为网格剩余高度+辅助项网格行数(默认为1)*数据行高度)、并设置其位置信息
  761.        .Height = Fzxwghs * Sjhgd + ((WglrGrid.Height - WglrGrid.FixedRows * WglrGrid.RowHeight(0)) Mod Sjhgd)
  762.        .RowHeight(0) = .Height
  763.        .Move 0, WglrGrid.Height - .Height, WglrGrid.Width, .Height
  764.     End With
  766. End Sub
  768. Private Sub Form_Resize()                                                '窗体大小发生变化时,重新显示文本框
  769.    Call Cxxswbk
  770. End Sub
  772. Private Function Fun_Drfrmyxxpd() As Boolean                             '调入其它窗体或功能产生的有效性判断(包括数据回写)
  773.     Fun_Drfrmyxxpd = True
  774.     With WglrGrid
  775.    
  776.         '如果当前网格处于编辑状态,则先进行数据回写再进行有效性判断
  777.         If Ydtext.Visible Or YdCombo.Visible Then
  778.             Call Lrsjhx
  779.             If Not sjzdyxxpd(Dqlrwgh, Dqlrwgl) Then
  780.                 Fun_Drfrmyxxpd = False
  781.                 Exit Function
  782.             End If
  783.         End If
  784.    
  785.         '进行行有效性判断
  786.         If Not Sjhzyxxpd(.Row) Then
  787.             Fun_Drfrmyxxpd = False
  788.             Exit Function
  789.         End If
  790.     End With
  792. End Function
  794. Private Sub WglrGrid_AfterUserResize(ByVal Row As Long, ByVal Col As Long)       '调整列宽
  795.     
  796.     If HjGrid.Visible Then
  797.         With HjGrid
  798.             .ColWidth(Col) = WglrGrid.ColWidth(Col)
  799.         End With
  800.     End If
  802. End Sub
  804. Private Sub WglrGrid_EnterCell()                                                 '显示当前数据行相关信息
  805.     
  806.     With WglrGrid
  807.         If .Row >= .FixedRows Then
  808.             '[>>
  809.             '此处可以填写显示与此网格行相关信息
  810.             '<<]
  811.         End If
  812.     End With
  814. End Sub
  816. Private Sub WglrGrid_GotFocus()                                     '网格得到焦点
  818.     '网格得到焦点,如果当前选择行为非数据行
  819.     '则调整当前焦点至有效数据行
  821.     With WglrGrid
  822.         If .Row < .FixedRows And .Rows > .FixedRows Then
  823.             Changelock = True
  824.             .Select .FixedRows, .Col
  825.             Changelock = False
  826.         End If
  827.         If .Col < Qslz Then
  828.             Changelock = True
  829.             .Select .Row, Qslz
  830.             Changelock = False
  831.         End If
  832.     End With
  834. End Sub
  836. Private Sub WglrGrid_LostFocus()                                    '录入网格失去焦点
  838.     '用以屏蔽调用其它窗体时发生网格失去焦点事件
  839.     If Changelock Then
  840.         Exit Sub
  841.     End If
  843.     '引发网格RowcolChange事件
  844.     With WglrGrid
  845.         If Not (Ydtext.Visible Or YdCombo.Visible) Then
  846.             .Select 0, 0
  847.         End If
  848.     End With
  850. End Sub
  852. Private Sub WglrGrid_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
  853. '鼠标右键弹出快捷菜单
  855.     If Button And vbRightButton Then
  856.         PopupMenu mnuSys, vbPopupMenuRightButton
  857.     End If
  859. End Sub
  861. Private Sub WglrGrid_AfterScroll(ByVal OldTopRow As Long, ByVal OldLeftCol As Long, ByVal NewTopRow As Long, ByVal NewLeftCol As Long)                                       '限制用户在录入过程中滚动鼠标
  863.     If Gdtlock Then
  864.         Exit Sub
  865.     End If
  866.  
  867.     With WglrGrid
  868.         If Ydtext.Visible Or YdCombo.Visible Then
  869.             Gdtlock = True
  870.             .TopRow = Dqtoprow
  871.             .LeftCol = Dqleftcol
  872.             Gdtlock = False
  873.             Exit Sub
  874.         End If
  875.         HjGrid.LeftCol = .LeftCol
  876.     End With
  878. End Sub
  880. Private Sub WglrGrid_LeaveCell()                                    '离开单元格
  881.     
  882.     If Changelock Then
  883.         Exit Sub
  884.     End If
  886.     '记录刚刚离开网格单元的行列值
  887.     Dqlkwgh = WglrGrid.Row
  888.     Dqlkwgl = WglrGrid.Col
  890.     '判断是否需要录入数据回写
  891.     If Not (Ydtext.Visible Or YdCombo.Visible) Then
  892.         Exit Sub
  893.     End If
  894.     Call Lrsjhx
  896. End Sub
  898. Private Sub WglrGrid_RowColChange()                                '网格录入行列发生变化时,进行有效性判断
  899.     Valilock = True       '屏蔽文本框失去焦点进行有效性判断
  900.     With WglrGrid
  901.         If Changelock Then
  902.             Exit Sub
  903.         End If
  904.         If Not sjzdyxxpd(Dqlrwgh, Dqlrwgl) Then
  905.             Exit Sub
  906.         End If
  907.         If .Row <> Dqlkwgh Then
  908.             If Not Sjhzyxxpd(Dqlkwgh) Then
  909.                 Exit Sub
  910.             End If
  911.         End If
  912.     End With
  913.    
  914.     Call fhyxh
  915.     Call Xldql
  916.    
  917. End Sub
  919. Private Sub WglrGrid_DblClick()          '鼠标双击网格显示文本框
  920.     
  921.     '判断是否输入仓库
  922.     If Lab_OperStatus = "2" Then
  923.         If Trim(LrText(1).Text) = "" Then
  924.             Tsxx = "请先输入仓库!"
  925.             Call Xtxxts(Tsxx, 0, 1)
  926.             LrText(1).SetFocus
  927.             Exit Sub
  928.         End If
  929.     End If
  930.   
  931.     With WglrGrid
  932.         Call xswbk
  933.     End With
  935. End Sub
  937. Private Sub Ycwbk()                      '隐藏文本框,帮助按钮,列表组合框
  938.     
  939.     Valilock = True
  940.     Ydtext.Visible = False
  941.     YdCombo.Visible = False
  942.     Ydcommand.Visible = False
  944. End Sub
  946. Private Sub YdCombo_KeyDown(KeyCode As Integer, Shift As Integer)        '列表框移动
  947.     With WglrGrid
  948.         Select Case KeyCode
  949.             Case vbKeyEscape                'ESC 键放弃录入
  950.                 Valilock = True
  951.                 .SetFocus
  952.                 Call Ycwbk
  953.                 Valilock = False
  954.             Case vbKeyReturn                '回 车 键 =13
  955.                 KeyCode = 0
  956.                 .SetFocus
  957.                 Call Lrsjhx
  958.                 Rowjsq = .Row
  959.                 Coljsq = .Col + 1
  960.                 If Coljsq > .Cols - 1 Then
  961.                     If Rowjsq < .Rows - 1 Then
  962.                         Rowjsq = Rowjsq + 1
  963.                     End If
  964.                     Coljsq = Qslz
  965.                 End If
  966.                 Do While Rowjsq <= .Rows - 1
  967.                     If .ColHidden(Coljsq) Or (Not GridBoolean(Coljsq, 1)) Then
  968.                         Coljsq = Coljsq + 1
  969.                         If Coljsq > .Cols - 1 Then
  970.                             Rowjsq = Rowjsq + 1
  971.                             Coljsq = Qslz
  972.                         End If
  973.                     Else
  974.                         Exit Do
  975.                     End If
  976.                 Loop
  977.                 .Select Rowjsq, Coljsq
  978.             Case vbKeyLeft                  '左 箭 头 =37
  979.                 If .Col - 1 = Qslz Then
  980.                     If .ColHidden(Qslz) Or (Not GridBoolean(Qslz, 1)) Then
  981.                         GoTo jzzx
  982.                     End If
  983.                 End If
  984.                 If .Col > Qslz Then
  985.                     KeyCode = 0
  986.                     .SetFocus
  987.                     Call Lrsjhx
  988.                     Coljsq = .Col - 1
  989.                     Do While Coljsq > Qslz
  990.                         If Coljsq - 1 = Qslz Then
  991.                             If .ColHidden(Qslz) Or (Not GridBoolean(Qslz, 1)) Then
  992.                                 GoTo jzzx
  993.                             End If
  994.                         End If
  995.                         If .ColHidden(Coljsq) Or (Not GridBoolean(Coljsq, 1)) Then
  996.                             Coljsq = Coljsq - 1
  997.                         Else
  998.                             Exit Do
  999.                         End If
  1000.                     Loop
  1001.                     .Select .Row, Coljsq
  1002.                 End If
  1003.             Case vbKeyRight                 '右 箭 头 =39
  1004.                 KeyCode = 0
  1005.                 .SetFocus
  1006.                 Call Lrsjhx
  1007.                 Rowjsq = .Row
  1008.                 Coljsq = .Col + 1
  1009.                 If Coljsq > .Cols - 1 Then
  1010.                     If Rowjsq < .Rows - 1 Then
  1011.                         Rowjsq = Rowjsq + 1
  1012.                     End If
  1013.                     Coljsq = Qslz
  1014.                 End If
  1015.                 Do While Rowjsq <= .Rows - 1
  1016.                     If .ColHidden(Coljsq) Or (Not GridBoolean(Coljsq, 1)) Then
  1017.                         Coljsq = Coljsq + 1
  1018.                         If Coljsq > .Cols - 1 Then
  1019.                             Rowjsq = Rowjsq + 1
  1020.                             Coljsq = Qslz
  1021.                         End If
  1022.                     Else
  1023.                         Exit Do
  1024.                     End If
  1025.                 Loop
  1026.                 .Select Rowjsq, Coljsq
  1027.         Case Else
  1028.    End Select
  1029.    
  1030. jzzx:
  1031.    
  1032.     End With
  1034. End Sub
  1036. Private Sub YdCombo_LostFocus()
  1037.   
  1038.     With WglrGrid                                    '因为选中网格会先发生Rowcolchange事件置Valiock
  1039.         If Not Valilock Then                           '为TRUE
  1040.             Call Lrsjhx
  1041.             If Not Sjhzyxxpd(Dqlrwgh) Then
  1042.                 Exit Sub
  1043.             End If
  1044.         End If
  1045.     End With
  1047. End Sub
  1049. Private Sub Ydcommand_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
  1050.     Call Lrzdbz
  1051. End Sub
  1053. Private Sub ydtext_KeyDown(KeyCode As Integer, Shift As Integer)
  1054.     Dim Rowjsq As Long, Coljsq As Long
  1055.     With WglrGrid
  1056.         Select Case KeyCode
  1057.             Case vbKeyF2
  1058.                 Call Lrzdbz
  1059.             Case vbKeyEscape                'ESC 键放弃录入
  1060.                 Valilock = True
  1061.                 Call Ycwbk
  1062.                 .SetFocus
  1063.             Case vbKeyReturn                '回 车 键 =13
  1064.                 KeyCode = 0
  1065.                 .SetFocus
  1066.                 Call Lrsjhx
  1067.                 Rowjsq = .Row
  1068.                 Coljsq = .Col + 1
  1069.                 If Coljsq > .Cols - 1 Then
  1070.                     If Rowjsq < .Rows - 1 Then
  1071.                         Rowjsq = Rowjsq + 1
  1072.                     End If
  1073.                     Coljsq = Qslz
  1074.                 End If
  1075.                 Do While Rowjsq <= .Rows - 1
  1076.                     If .ColHidden(Coljsq) Or (Not GridBoolean(Coljsq, 1)) Then
  1077.                         Coljsq = Coljsq + 1
  1078.                         If Coljsq > .Cols - 1 Then
  1079.                             Rowjsq = Rowjsq + 1
  1080.                             Coljsq = Qslz
  1081.                         End If
  1082.                     Else
  1083.                         Exit Do
  1084.                     End If
  1085.                 Loop
  1086.                 If Rowjsq <= .Rows - 1 Then
  1087.                     .Select Rowjsq, Coljsq
  1088.                 End If
  1089.             Case vbKeyUp                    '上 箭 头 =38
  1090.                 KeyCode = 0
  1091.                 .SetFocus
  1092.                 Call Lrsjhx
  1093.                 If .Row > .FixedRows Then
  1094.                     .Row = .Row - 1
  1095.                 End If
  1096.             Case vbKeyDown                  '下 箭 头 =40
  1097.                 KeyCode = 0
  1098.                 .SetFocus
  1099.                 Call Lrsjhx
  1100.                 If .Row < .Rows - 1 Then
  1101.                     .Row = .Row + 1
  1102.                 End If
  1103.             Case vbKeyLeft                  '左 箭 头 =37
  1104.                 If .Col - 1 = Qslz Then
  1105.                     If .ColHidden(Qslz) Or (Not GridBoolean(Qslz, 1)) Then
  1106.                         GoTo jzzx
  1107.                     End If
  1108.                 End If
  1109.                 If Ydtext.SelStart = 0 And .Col > Qslz Then
  1110.                     KeyCode = 0
  1111.                     .SetFocus
  1112.                     Call Lrsjhx
  1113.                     Coljsq = .Col - 1
  1114.                     Do While Coljsq > Qslz
  1115.                         If Coljsq - 1 = Qslz Then
  1116.                             If .ColHidden(Qslz) Or (Not GridBoolean(Qslz, 1)) Then
  1117.                                 GoTo jzzx
  1118.                             End If
  1119.                         End If
  1120.                         If .ColHidden(Coljsq) Or (Not GridBoolean(Coljsq, 1)) Then
  1121.                             Coljsq = Coljsq - 1
  1122.                         Else
  1123.                             Exit Do
  1124.                         End If
  1125.                     Loop
  1126.                     .Select .Row, Coljsq
  1127.                 End If
  1128. jzzx:
  1129.             Case vbKeyRight                 '右 箭 头 =39
  1130.                 wblong = Len(Ydtext.Text)
  1131.                 If (Ydtext.SelStart = wblong Or Ydtext.SelLength = wblong) Then
  1132.                     KeyCode = 0
  1133.                     .SetFocus
  1134.                     Call Lrsjhx
  1135.                     Rowjsq = .Row
  1136.                     Coljsq = .Col + 1
  1137.                     If Coljsq > .Cols - 1 Then
  1138.                         If Rowjsq < .Rows - 1 Then
  1139.                             Rowjsq = Rowjsq + 1
  1140.                         End If
  1141.                         Coljsq = Qslz
  1142.                     End If
  1143.                     Do While Rowjsq <= .Rows - 1
  1144.                         If .ColHidden(Coljsq) Or (Not GridBoolean(Coljsq, 1)) Then
  1145.                             Coljsq = Coljsq + 1
  1146.                             If Coljsq > .Cols - 1 Then
  1147.                                 Rowjsq = Rowjsq + 1
  1148.                                 Coljsq = Qslz
  1149.                             End If
  1150.                         Else
  1151.                             Exit Do
  1152.                         End If
  1153.                     Loop
  1154.                     .Select Rowjsq, Coljsq
  1155.                 End If
  1156.             Case Else
  1157.         End Select
  1158.     End With
  1160. End Sub
  1162. Private Sub ydtext_KeyPress(KeyAscii As Integer)         '录入字符事中控制
  1163.     
  1164.     Call InputFieldLimit(Ydtext, GridInt(WglrGrid.Col, 1), KeyAscii)
  1165.     If KeyAscii <> 0 Then
  1166.         Call Xyxhbz(Dqlrwgh)
  1167.     End If
  1169. End Sub
  1171. Private Sub ydtext_Change()                              '录入事中变化处理
  1173.     '防止程序改变但不进行处理
  1175.     If Wbkbhlock Then
  1176.         Exit Sub
  1177.     End If
  1179.     With WglrGrid
  1180.         '限制字段录入长度
  1181.         Wbkbhlock = True
  1182.         Call TextChangeLimit(Ydtext, GridInt(.Col, 1))  '去掉无效字符
  1183.         Select Case GridInt(.Col, 1)
  1184.             Case 8, 11   '金额型
  1185.                 Call Sjgskz(Ydtext, Xtjezws - Xtjexsws - 1, Xtjexsws)
  1186.             Case 9, 12   '数量型
  1187.                 Call Sjgskz(Ydtext, Xtslzws - Xtslxsws - 1, Xtslxsws)
  1188.             Case 10      '单价型
  1189.                 Call Sjgskz(Ydtext, Xtdjzws - Xtdjxsws - 1, Xtdjxsws)
  1190.             Case Else    '其他类型
  1191.                 If GridInt(.Col, 3) <> 0 Or GridInt(.Col, 4) <> 0 Then
  1192.                     Call Sjgskz(Ydtext, GridInt(.Col, 3), GridInt(.Col, 4))
  1193.                 End If
  1194.         End Select
  1195.         Wbkbhlock = False
  1196.     End With
  1198. End Sub
  1200. Private Sub ydtext_LostFocus()            '如果由于选中网格之外的控件而发生有效性判断(选中网格会先发生Rowcolchange事件置Valiock为TRUE)
  1201.   
  1202.     With WglrGrid
  1203.         If Not Valilock Then
  1204.             Call Lrsjhx
  1205.             If Not sjzdyxxpd(Dqlrwgh, Dqlrwgl) Then
  1206.                 Exit Sub
  1207.             End If
  1208.             If Not Sjhzyxxpd(Dqlrwgh) Then
  1209.                 Exit Sub
  1210.             End If
  1211.         End If
  1212.     End With
  1214. End Sub
  1216. Private Sub xswbk()                       '在当前选中单元显示文本框,列表框,帮助按钮(通用)
  1217.     
  1218.     Dim Wbkpy As Integer, Wbkpy1 As Integer '文本框偏移量
  1219.   
  1220.     '当某种条件成立时禁止文本框激活使单据处于录入状态
  1221.     If Not Fun_AllowInput Then
  1222.         Exit Sub
  1223.     End If
  1224.   
  1225.     '显示文本框前返回有效行列（解决滚动条问题）
  1226.     Call Xldqh
  1227.     Call Xldql
  1228.   
  1229.     '隐藏文本框,帮助按钮,列表组合框
  1230.     Call Ycwbk
  1231.   
  1232.     With WglrGrid
  1233.         Dqlrwgh = .Row
  1234.         Dqlrwgl = .Col
  1235.         If Not GridBoolean(.Col, 1) Or .Row < .FixedRows Then
  1236.             Exit Sub
  1237.         End If
  1238.      
  1239.         Wbkpy = 30
  1240.         Wbkpy1 = 15
  1241.         
  1242.         On Error Resume Next
  1243.         
  1244.         If GridBoolean(.Col, 3) Then
  1245.             YdCombo.Left = .CellLeft + .Left + Wbkpy
  1246.             YdCombo.Top = .CellTop + .Top + Wbkpy
  1247.             YdCombo.Width = .CellWidth - Wbkpy1
  1248.             Call Wbkcl
  1249.             YdCombo.Visible = True
  1250.             YdCombo.SetFocus
  1251.             Ydcommand.Visible = False
  1252.             Ydtext.Visible = False
  1253.         Else
  1254.             If GridBoolean(.Col, 2) Then
  1255.                 Ydcommand.Left = .Left + .CellLeft + .CellWidth - Ydcommand.Width + Wbkpy
  1256.                 Ydcommand.Top = .Top + .CellTop + .CellHeight - Ydcommand.Height + Wbkpy
  1257.                 Ydcommand.Visible = True
  1258.             Else
  1259.                 Ydcommand.Visible = False
  1260.             End If
  1261.              
  1262.             Ydtext.Left = .CellLeft + .Left + Wbkpy
  1263.             Ydtext.Top = .CellTop + .Top + Wbkpy
  1264.             If Ydcommand.Visible Then
  1265.                 If Sfblbzkd Then
  1266.                     Ydtext.Width = .CellWidth - Ydcommand.Width
  1267.                 Else
  1268.                     Ydtext.Width = .CellWidth - Wbkpy1
  1269.                 End If
  1270.             Else
  1271.                 Ydtext.Width = .CellWidth - Wbkpy1
  1272.             End If
  1273.             Ydtext.Height = .CellHeight - Wbkpy1
  1274.         
  1275.             If GridInt(.Col, 2) <> 0 Then
  1276.                 Ydtext.MaxLength = GridInt(.Col, 2)
  1277.             Else
  1278.                 Ydtext.MaxLength = 3000
  1279.             End If
  1280.       
  1281.             Call Wbkcl
  1282.       
  1283.             Ydtext.Visible = True
  1284.             Ydtext.SetFocus
  1285.         End If
  1286.         Dqtoprow = .TopRow
  1287.         Dqleftcol = .LeftCol
  1288.         
  1289.         '重置锁值
  1290.         Valilock = False
  1291.         Wbkbhlock = False
  1292.     End With
  1294. End Sub
  1296. Private Function Fun_AllowInput() As Boolean                           '当某种条件成立时禁止文本框激活使单据处于录入状态
  1297.    
  1298.     '如果单据操作状态为浏览状态则不能显示录入载体(通用)
  1299.     If Trim(Lab_OperStatus.Caption) = "1" Then
  1300.         Exit Function
  1301.     End If
  1302.    
  1303.     '[>>
  1304.     
  1305.     '此处可以填写禁止文本框激活使单据处于录入状态的理由
  1306.     '判断是否输入仓库
  1307.     If Lab_OperStatus = "2" Then
  1308.         If Trim(LrText(1).Text) = "" Then
  1309.             Tsxx = "请先输入仓库!"
  1310.             Call Xtxxts(Tsxx, 0, 1)
  1311.             LrText(1).SetFocus
  1312.             Exit Function
  1313.         End If
  1314.     End If
  1315.     '<<]
  1316.    
  1317.     Fun_AllowInput = True
  1319. End Function
  1321. Private Sub Cxxswbk()                                                  'Formresize中重新显示文本框,列表框,帮助按钮(通用)
  1322.                    
  1323.     Dim Wbkpy As Integer, Wbkpy1 As Integer
  1324.     Wbkpy = 30
  1325.     Wbkpy1 = 15
  1326.     With WglrGrid
  1327.         If YdCombo.Visible Then
  1328.             YdCombo.Left = .CellLeft + .Left + Wbkpy
  1329.             YdCombo.Top = .CellTop + .Top + Wbkpy
  1330.             YdCombo.Width = .CellWidth - Wbkpy1
  1331.         End If
  1332.         If Ydcommand.Visible Then
  1333.             Ydcommand.Left = .Left + .CellLeft + .CellWidth - Ydcommand.Width + Wbkpy
  1334.             Ydcommand.Top = .Top + .CellTop + .CellHeight - Ydcommand.Height + Wbkpy
  1335.         End If
  1336.         If Ydtext.Visible Then
  1337.             If Ydcommand.Visible Then
  1338.                 If Sfblbzkd Then
  1339.                     Ydtext.Width = .CellWidth - Ydcommand.Width
  1340.                 Else
  1341.                     Ydtext.Width = .CellWidth - Wbkpy1
  1342.                 End If
  1343.             Else
  1344.                 Ydtext.Width = .CellWidth - Wbkpy1
  1345.             End If
  1346.             Ydtext.Left = .CellLeft + .Left + Wbkpy
  1347.             Ydtext.Top = .CellTop + .Top + Wbkpy
  1348.             Ydtext.Height = .CellHeight - Wbkpy1
  1349.         End If
  1350.     End With
  1352. End Sub
  1354. Private Sub Lrsjhx()                                                   '文本框录入数据回写
  1355.     
  1356.     With WglrGrid
  1357.         If YdCombo.Visible Then
  1358.             .Text = Trim(YdCombo.Text)
  1359.         End If
  1360.         If Ydtext.Visible Then
  1361.             .Text = Trim(Ydtext.Text)
  1362.         End If
  1363.         
  1364.         '(如果字段录入内容发生变化,则打开有效性判断锁)
  1365.         If Zdlrqnr <> Trim(.Text) Then
  1366.             Yxxpdlock = False
  1367.             Hyxxpdlock = False
  1368.         End If
  1369.     
  1370.         '如果字段录入内容不为空则写数据行有效性标志
  1371.         If Len(Trim(.Text)) <> 0 Then
  1372.             Call Xyxhbz(.Row)
  1373.         End If
  1374.     
  1375.         '隐藏文本框,帮助按钮,列表组合框
  1376.         Call Ycwbk
  1377.     End With
  1379. End Sub
  1381. Private Sub WglrGrid_KeyDown(KeyCode As Integer, Shift As Integer)    '网格录入增行,删行快捷键
  1382.   
  1383.     '如果单据操作状态为浏览状态则不能显示录入载体
  1384.     If Trim(Lab_OperStatus.Caption) = "1" Then
  1385.         Exit Sub
  1386.     End If
  1388.     Select Case KeyCode
  1389.         Case vbKeyF2                   '按F2键参照
  1390.             Call xswbk
  1391.             Call Lrzdbz
  1392.         Case vbKeyDelete               '删行
  1393.             Call Scdqfl
  1394.         Case vbKeyInsert               '增行
  1395.             Call zjlrfl
  1396.     End Select
  1398. End Sub
  1400. Private Sub WglrGrid_KeyPress(KeyAscii As Integer)                             '网格接受键盘录入
  1402.     '当某种条件成立时禁止文本框激活使单据处于录入状态
  1403.     If Not Fun_AllowInput Then
  1404.         Exit Sub
  1405.     End If
  1406.   
  1407.     With WglrGrid
  1408.         '屏 蔽 回 车 键
  1409.         If KeyAscii = vbKeyReturn Then
  1410.             KeyAscii = 0
  1411.             Rowjsq = .Row
  1412.             Coljsq = .Col + 1
  1413.             If Coljsq > .Cols - 1 Then
  1414.                 If Rowjsq < .Rows - 1 Then
  1415.                     Rowjsq = Rowjsq + 1
  1416.                 End If
  1417.                 Coljsq = Qslz
  1418.             End If
  1419.             Do While Rowjsq <= .Rows - 1
  1420.                 If .ColHidden(Coljsq) Or (Not GridBoolean(Coljsq, 1)) Then
  1421.                     Coljsq = Coljsq + 1
  1422.                     If Coljsq > .Cols - 1 Then
  1423.                         Rowjsq = Rowjsq + 1
  1424.                         Coljsq = Qslz
  1425.                     End If
  1426.                 Else
  1427.                     Exit Do
  1428.                 End If
  1429.             Loop
  1430.             If Rowjsq <= .Rows - 1 Then
  1431.                 .Select Rowjsq, Coljsq
  1432.             End If
  1433.             Exit Sub
  1434.         End If
  1435.      
  1436.         '接受用户录入
  1437.         Select Case KeyAscii
  1438.             Case 0 To 32             '用户输入KeyAscii为0-32的键 如空格
  1439.                 '显示录入载体
  1440.                 Call xswbk
  1441.             Case Else
  1442.                 '防止非编辑字段SendKeys()出现死循环
  1443.                 If Not GridBoolean(.Col, 1) Or .Row < .FixedRows Then
  1444.                     Exit Sub
  1445.                 End If
  1446.                 '如果此字段为列表框录入则调入相应列表框
  1447.                 If GridBoolean(.Col, 3) Then
  1448.                     '列表框录入
  1449.                     Call xswbk
  1450.                 Else
  1451.                     Ydtext.Text = ""
  1452.                     '录入限制
  1453.                     Call InputFieldLimit(Ydtext, GridInt(WglrGrid.Col, 1), KeyAscii)
  1454.                     If KeyAscii = 0 Then
  1455.                         Exit Sub
  1456.                     End If
  1457.                     '如果录入字符有效则写有效行数据标志
  1458.                     Call Xyxhbz(.Row)
  1459.                     Call xswbk
  1460.                     Ydtext.Text = ""
  1461.                     Valilock = True
  1462.                     SendKeys Chr(KeyAscii), True
  1463.                     DoEvents
  1464.                     Valilock = False
  1465.                 End If
  1466.         End Select
  1467.     End With
  1469. End Sub
  1471. Private Sub zjlrfl()                                                    '增加录入分录
  1472.     
  1473.     With WglrGrid
  1474.         If Not (Ydtext.Visible Or YdCombo.Visible) Then
  1475.             If Not Fun_Drfrmyxxpd Then
  1476.                 Exit Sub
  1477.             End If
  1478.         Else
  1479.             Exit Sub
  1480.         End If
  1481.         If .Row < .FixedRows Then
  1482.             Exit Sub
  1483.         End If
  1484.         .AddItem "", .Row
  1485.         .RowHeight(.Row) = Sjhgd
  1486.         If .Row <> .Rows - 1 Then
  1487.             If .TextMatrix(.Row + 1, 0) = "*" Then
  1488.                 .TextMatrix(.Row, 0) = "*"
  1489.             Else
  1490.                 .RemoveItem .Rows - 1
  1491.             End If
  1492.         End If
  1493.         Call Xldqh
  1494.         Call Xldql
  1495.         Hyxxpdlock = False
  1496.     End With
  1498. End Sub
  1500. Private Sub Scdqfl()                                                    '删除当前分录
  1501.     Dim Answer As Integer, Scqwghz As Long, Scqwglz As Long, Hjlzte As Long, Sflrzt As Boolean
  1502.     With WglrGrid
  1503.         Scqwghz = .Row
  1504.         Scqwglz = .Col
  1505.         If .TextMatrix(.Row, 0) = "*" Then
  1506.             '判断是否为录入状态
  1507.             If Ydtext.Visible Or YdCombo.Visible Then
  1508.                 Sflrzt = True
  1509.                 Validate = True
  1510.                 Call Lrsjhx
  1511.                 Validate = False
  1512.             End If
  1513.             Call Xldqh
  1514.             Changelock = True
  1515.             .Select .Row, 0
  1516.             Changelock = False
  1517.             If Shsfts Then
  1518.                 .Cell(flexcpBackColor, .Row, Qslz, .Row, .Cols - 1) = QBColor(12)
  1519.                 Tsxx = "请确认是否删除当前记录?"
  1520.                 Yhanswer = Xtxxts(Tsxx, 2, 2)
  1521.                 If Yhanswer = 2 Then
  1522.                     .Cell(flexcpBackColor, .Row, Qslz, .Row, .Cols - 1) = &H80000005
  1523.                     Changelock = True
  1524.                     .Select Scqwghz, Scqwglz
  1525.                     Changelock = False
  1526.                     
  1527.                     '如为录入状态,则恢复录入
  1528.                     If Sflrzt Then
  1529.                         Call xswbk
  1530.                     End If
  1531.                     Exit Sub
  1532.                 End If
  1533.             End If
  1534.             .RemoveItem .Row
  1535.             If .Rows < Pmbcsjhs + .FixedRows + Fzxwghs + 1 Then
  1536.                 .AddItem ""
  1537.                 .RowHeight(.Rows - 1) = Sjhgd
  1538.             End If
  1539.             Changelock = True
  1540.             .Select .Row, Scqwglz
  1541.             Changelock = False
  1542.    
  1543.             '重新计算合计数据
  1544.             For Hjlzte = Qslz To .Cols - 1
  1545.                 Call Sjhj(Hjlzte)
  1546.             Next Hjlzte
  1547.         End If
  1548.     End With
  1550. End Sub
  1552. Private Sub Sjhj(Hjwgl As Long)                                         '网格列数据合计
  1553.     
  1554.     Dim Hjjg As Double
  1555.     If Not (GridBoolean(Hjwgl, 4) And HjGrid.Visible) Then
  1556.         Exit Sub
  1557.     End If
  1558.     With WglrGrid
  1559.         Hjjg = 0
  1560.         For jsqte = .FixedRows To .Rows - 1
  1561.             If .TextMatrix(jsqte, 0) = "*" Then
  1562.                 Hjjg = Hjjg + Val(.TextMatrix(jsqte, Hjwgl))
  1563.             End If
  1564.         Next jsqte
  1565.         If GridBoolean(Hjwgl, 5) And Hjjg = 0 Then
  1566.             HjGrid.TextMatrix(0, Hjwgl) = ""
  1567.         Else
  1568.             HjGrid.TextMatrix(0, Hjwgl) = Hjjg
  1569.         End If
  1570.     End With
  1572. End Sub
  1574. Private Sub Qkwlzd(sjh As Long, Sjl As Long)                            '清空为零字段
  1575.     
  1576.     If Not GridBoolean(Sjl, 5) Then
  1577.         Exit Sub
  1578.     End If
  1579.     With WglrGrid
  1580.         If Val(Trim(.TextMatrix(sjh, Sjl))) = 0 Then
  1581.             .TextMatrix(sjh, Sjl) = ""
  1582.         End If
  1583.     End With
  1585. End Sub
  1587. Private Sub fhyxh()                                                     '返回录入数据有效行,同时让得到焦点网格可见
  1588.     
  1589.     With WglrGrid
  1590.         If .Row >= .FixedRows Then
  1591.             If .TextMatrix(.Row, 0) <> "*" Then
  1592.                 For Rowjsq = .FixedRows To .Rows - 1
  1593.                     If .TextMatrix(Rowjsq, 0) <> "*" Then
  1594.                         Exit For
  1595.                     End If
  1596.                 Next Rowjsq
  1597.                 If Rowjsq <= .Rows - 1 Then
  1598.                     Changelock = True
  1599.                     .Select Rowjsq, .Col
  1600.                     Changelock = False
  1601.                 Else
  1602.                     Changelock = True
  1603.                     .Select .Rows - 1, .Col
  1604.                     Changelock = False
  1605.                 End If
  1606.             End If
  1607.             Call Xldqh
  1608.         End If
  1609.   End With
  1610.   
  1611. End Sub
  1613. Private Sub Xldqh()                                                      '显露当前行
  1614.   
  1615.     Dim Toprowte As Long
  1616.     With WglrGrid
  1617.         Toprowte = 0
  1618.         Do While .CellTop + .RowHeight(.Row) + Fzxwghs * Sjhgd > .Height And .TopRow <> Toprowte
  1619.             Toprowte = .TopRow
  1620.             .TopRow = .TopRow + 1
  1621.         Loop
  1622.         Toprowte = 0
  1623.         Do While .CellTop < .FixedRows * .RowHeight(0) And .TopRow <> Toprowte
  1624.             Toprowte = .TopRow
  1625.             If .TopRow > 1 Then
  1626.                 .TopRow = .TopRow - 1
  1627.             End If
  1628.         Loop
  1629.     End With
  1631. End Sub
  1633. Private Sub Xldql()                                                     '显露当前列
  1634.     
  1635.     Dim Leftcolte As Long
  1636.     With WglrGrid
  1637.         If .Col >= Qslz And .Col >= .FixedCols Then
  1638.             If .LeftCol > .Col Then
  1639.                 .LeftCol = .Col
  1640.             End If
  1641.             Leftcolte = 0
  1642.             Do While .CellLeft + .CellWidth > .Width And .LeftCol <> Leftcolte
  1643.                 Leftcolte = .LeftCol
  1644.                 .LeftCol = .LeftCol + 1
  1645.             Loop
  1646.         End If
  1647.     End With
  1649. End Sub
  1651. Private Function pdhwk(sjh As Long)                                     '判断网格行是否为空行(所有录入字段均为空*非录入字段除外)
  1652.     
  1653.     With WglrGrid
  1654.         For Coljsq = Qslz To .Cols - 1
  1655.             If Len(Trim(.TextMatrix(sjh, Coljsq))) <> 0 And GridBoolean(Coljsq, 1) Then
  1656.                 pdhwk = False
  1657.                 Exit Function
  1658.             End If
  1659.         Next Coljsq
  1660.         pdhwk = True
  1661.     End With
  1663. End Function
  1665. Private Sub Xyxhbz(sjh As Long)                                         '写行有效性标志,并判断是否增行
  1666.     
  1667.     With WglrGrid
  1668.         If .TextMatrix(sjh, 0) = "*" Then
  1669.             Exit Sub
  1670.         End If
  1671.         .TextMatrix(sjh, 0) = "*"
  1672.         If sjh >= .Rows - Fzxwghs - 1 Then
  1673.             .AddItem ""
  1674.             .RowHeight(.Rows - 1) = Sjhgd
  1675.         End If
  1676.     End With
  1678. End Sub
  1680. '*****************************以下为文本框录入处理程序(固定不变部分)*******************************'
  1682. Private Sub Wbklrwbcl(Index As Integer)    '文本框录入事后处理程序
  1683.     
  1684.     Dim adoRecTemp As New ADODB.Recordset
  1685.     Dim RecTemp As New ADODB.Recordset
  1686.     Dim strSQL As String
  1687.     Dim JsqTemp As Integer
  1688.     Dim strSQLTemp As String
  1689.     
  1690.     If Trim(LrText(Index).Text) <> "" Then
  1691.         Select Case Index
  1692.             Case 0          '发货单<<根据发货单填充相应内容>>
  1693.                 If LrText(0).Tag <> "" Then
  1694.                     Int_BillNum = LrText(0).Tag
  1695.                 End If
  1697.                 If Lab_OperStatus <> "1" Then
  1698.                     Call FillBill
  1699.                 End If
  1700.                 
  1701.             Case 1          '仓库<<根据所选择仓库的管理方式,并隐藏或显示相应的列>>
  1702.                 strSQL = "SELECT * FROM GY_WareHouse WHERE WhCode='" & Trim(LrText(1).Tag) & "'"
  1703.                 Set adoRecTemp = Cw_DataEnvi.DataConnect.Execute(strSQL)
  1704.                 With adoRecTemp
  1705.                     If Not .EOF Then
  1706.                         If .Fields("Ishqgl") = True Then
  1707.                             HideArea = False
  1708.                         Else
  1709.                             HideArea = True
  1710.                         End If
  1711.                         
  1712.                     End If
  1713.                 End With
  1714.                 adoRecTemp.Close
  1715.                 Set adoRecTemp = Nothing
  1716.                 
  1717.                 If conArea = 1 Then
  1718.                     If HideArea = True Then
  1719.                         WglrGrid.ColHidden(Sydz("005", GridStr(), Szzls)) = True
  1720.                     Else
  1721.                         WglrGrid.ColHidden(Sydz("005", GridStr(), Szzls)) = False
  1722.                     End If
  1723.                 Else
  1724.                     WglrGrid.ColHidden(Sydz("005", GridStr(), Szzls)) = True
  1725.                 End If
  1726.                 
  1727.                 '根据仓库记价方式,显示或隐藏相应列
  1728.                 If PriceMode = "计划价法" Then
  1729.                     WglrGrid.ColHidden(Sydz("012", GridStr(), Szzls)) = False
  1730.                     WglrGrid.ColHidden(Sydz("013", GridStr(), Szzls)) = False
  1731.                     '如果仓库为计划价法,列表中有物料,判断此无料的计划单价,并填充
  1732.                     If WglrGrid.Rows > WglrGrid.FixedRows Then
  1733.                         RowsMax = WglrGrid.Rows - WglrGrid.FixedRows
  1734.                         For JsqTemp = WglrGrid.FixedRows To RowsMax
  1735.                             strSQLTemp = "SELECT mnumber,mname,planprice FROM Gy_Material Where mnumber='" & WglrGrid.TextMatrix(JsqTemp, Sydz("001", GridStr(), Szzls)) & "'"
  1736.                             Set RecTemp = Cw_DataEnvi.DataConnect.Execute(strSQLTemp)
  1737.                             If Not RecTemp.EOF Then
  1738.                                 If Val(RecTemp.Fields("planprice")) <> 0 Then
  1739.                                     WglrGrid.TextMatrix(JsqTemp, Sydz("012", GridStr(), Szzls)) = RecTemp.Fields("planprice")
  1740.                                     WglrGrid.TextMatrix(JsqTemp, Sydz("013", GridStr(), Szzls)) = Format(RecTemp.Fields("planprice") * WglrGrid.ValueMatrix(JsqTemp, Sydz("007", GridStr(), Szzls)), "###0." + String(Xtjexsws, "0"))
  1741.                                 Else
  1742.                                     WglrGrid.TextMatrix(JsqTemp, Sydz("012", GridStr(), Szzls)) = ""
  1743.                                     WglrGrid.TextMatrix(JsqTemp, Sydz("013", GridStr(), Szzls)) = ""
  1744.                                 End If
  1745.                             End If
  1746.                         Next JsqTemp
  1747.                         RecTemp.Close
  1748.                         Set RecTemp = Nothing
  1749.                     End If
  1750.                 Else
  1751.                     WglrGrid.ColHidden(Sydz("012", GridStr(), Szzls)) = True
  1752.                     WglrGrid.ColHidden(Sydz("013", GridStr(), Szzls)) = True
  1753.                 End If
  1754.                 
  1755.                 Call Cshhjwg
  1756.                 '读取最新的单据编码
  1757.                 LrText(2).Text = CreatBillCode(BillCode, False, Xtyear, Xtmm, Trim(LrText(1).Tag))
  1758.         End Select
  1759.     End If
  1760.     ']以上为依据实际情况自定义部分
  1762. End Sub
  1763. Private Sub FillBill()
  1764. '模块功能：根据用户输入的收料通知单号,自动填充相关字段
  1765. '          当为蓝字时,显示收料通知单,当为红字时为退货单
  1767.     Dim Rec_Bill As New Recordset
  1768.     Dim jsqte As Integer
  1769.     Dim Rec_WH As New Recordset
  1770.     Dim dblQuan As Double
  1771.     Dim dblTemp As Double
  1772.     Dim dblResult As Double
  1773.     
  1774.     '取得符合条件的记录
  1775.     Set Rec_Bill = Cw_DataEnvi.DataConnect.Execute("select * from Kf_V_ConsignBill where ConsignBillMainId=" & Int_BillNum)
  1776.     With Rec_Bill
  1777.         If Not .EOF Then
  1778.             WglrGrid.Rows = .RecordCount + WglrGrid.FixedRows
  1779.             LrText(1).Text = Trim(.Fields("WhName") & "")
  1780.             LrText(1).Tag = Trim(.Fields("StorageCode") & "")
  1781.             LrText(2).Text = CreatBillCode(BillCode, False, Xtyear, Xtmm, Trim(.Fields("StorageCode")))
  1782.             LrText(2).Enabled = False
  1783.             LrText(3).Text = Trim(.Fields("CusName") & "")
  1784.             LrText(3).Tag = Trim(.Fields("CusCode") & "")
  1785.             LrText(3).Enabled = False
  1786.             '如果仓库设置为货区管理,则显示该列
  1787.             If conArea = 1 Then
  1788.                 If CBool(.Fields("ishqgl")) = True Then
  1789.                     WglrGrid.ColHidden(Sydz("005", GridStr(), Szzls)) = False
  1790.                 Else
  1791.                     WglrGrid.ColHidden(Sydz("005", GridStr(), Szzls)) = True
  1792.                 End If
  1793.             End If
  1794.             
  1795.             jsqte = WglrGrid.FixedRows
  1796.          
  1797.             Do While Not .EOF
  1798.                 If jsqte >= WglrGrid.Rows Then
  1799.                     WglrGrid.AddItem ""
  1800.                 End If
  1801.                 '如果数量为0,则继续显示下一条记录
  1802.                 If OptRed.Value = True Then
  1803.                     dblQuan = 0 - Val(.Fields("Quantity"))
  1804.                     dblTemp = 0 - Val(.Fields("EmergeQuantity"))
  1805.                 Else
  1806.                     dblQuan = Val(.Fields("Quantity"))
  1807.                     dblTemp = Val(.Fields("EmergeQuantity"))
  1808.                 End If
  1809.                 dblResult = dblQuan - dblTemp
  1810.                 If dblResult > 0 Then
  1811.                     '[>>显示单据分录
  1812.                     WglrGrid.TextMatrix(jsqte, 0) = "*"
  1813.                     WglrGrid.TextMatrix(jsqte, 2) = Rec_Bill.Fields("Ispcgl")
  1814.                     WglrGrid.TextMatrix(jsqte, 3) = Rec_Bill.Fields("Isbzqgl")
  1815.                     WglrGrid.TextMatrix(jsqte, Sydz("001", GridStr(), Szzls)) = Trim(.Fields("mnumber"))
  1816.                     WglrGrid.TextMatrix(jsqte, Sydz("002", GridStr(), Szzls)) = Trim(.Fields("mname"))
  1817.                     WglrGrid.TextMatrix(jsqte, Sydz("003", GridStr(), Szzls)) = Trim(.Fields("model"))
  1818.                     WglrGrid.TextMatrix(jsqte, Sydz("004", GridStr(), Szzls)) = Trim(.Fields("PrimaryUnitName"))
  1819.                 
  1820.                     WglrGrid.TextMatrix(jsqte, Sydz("007", GridStr(), Szzls)) = Format(KFChangeXS(dblResult, Trim(.Fields("mnumber")), 0), "###0." + String(Xtslxsws, "0"))
  1821.                     WglrGrid.TextMatrix(jsqte, Sydz("011", GridStr(), Szzls)) = Format(KFChangeXS(dblResult, Trim(.Fields("mnumber")), 0), "###0." + String(Xtslxsws, "0"))
  1822.                     PriceMode = Trim(.Fields("PriceMode"))
  1823.                     If Trim(.Fields("PriceMode")) <> "计划价法" Then
  1824.                         WglrGrid.ColHidden(Sydz("012", GridStr(), Szzls)) = True
  1825.                         WglrGrid.ColHidden(Sydz("013", GridStr(), Szzls)) = True
  1826.                     Else
  1827.                         WglrGrid.ColHidden(Sydz("012", GridStr(), Szzls)) = False
  1828.                         WglrGrid.ColHidden(Sydz("013", GridStr(), Szzls)) = False
  1829.                         If Val(.Fields("planprice")) <> 0 Then
  1830.                             WglrGrid.TextMatrix(jsqte, Sydz("012", GridStr(), Szzls)) = Trim(.Fields("planprice"))
  1831.                             WglrGrid.TextMatrix(jsqte, Sydz("013", GridStr(), Szzls)) = Format(.Fields("planprice") * WglrGrid.ValueMatrix(jsqte, Sydz("011", GridStr(), Szzls)), "##." + String(Xtjexsws, "0"))
  1832.                         End If
  1833.                     End If
  1834.                                                         
  1835.                     WglrGrid.RowHeight(jsqte) = Sjhgd
  1836.                     .MoveNext
  1837.                     jsqte = jsqte + 1
  1838.                 Else
  1839.                     .MoveNext
  1840.                 End If
  1841.             Loop
  1842.         End If
  1843.     End With
  1844.     '调整网格
  1845.      Call Sub_AdjustGrid
  1846.      Call Cshhjwg
  1847.     '计算合计数据
  1848.      Dim jsq1 As Long
  1849.      For jsq1 = Qslz To WglrGrid.Cols - 1
  1850.         Call Sjhj(jsq1)
  1851.      Next jsq1
  1852.      bill_flag = True
  1854.     
  1855. End Sub
  1856. Private Sub LrText_Change(Index As Integer)
  1858.     Dim rjsq As Integer
  1859.     
  1860.     '屏蔽程序改变控制
  1861.     If TextChangeLock Then
  1862.         Exit Sub
  1863.     End If
  1864.    
  1865.     TextValiJudgeLock(Index) = False    '打开有效性判断锁
  1866.         
  1867.     '限制字段录入长度
  1868.           
  1869.     TextChangeLock = True  '加锁(防止执行Lrtext_Change)
  1870.     Call TextChangeLimit(LrText(Index), Textint(Index, 1))  '去掉无效字符
  1871.         Select Case Textint(Index, 1)
  1872.             Case 8, 11       '金额型
  1873.                 Call Sjgskz(LrText(Index), Xtjezws - Xtjexsws - 1, Xtjexsws)
  1874.             Case 9, 12       '数量型
  1875.                 Call Sjgskz(LrText(Index), Xtslzws - Xtslxsws - 1, Xtslxsws)
  1876.             Case 10          '单价型
  1877.                 Call Sjgskz(LrText(Index), Xtdjzws - Xtdjxsws - 1, Xtdjxsws)
  1878.             Case Else        '其他小数类型控制
  1879.                 If Textint(Index, 6) <> 0 Or Textint(Index, 7) <> 0 Then
  1880.                     Call Sjgskz(LrText(Index), Textint(Index, 6), Textint(Index, 7))
  1881.                 End If
  1882.         End Select
  1883.         
  1884.         TextChangeLock = False '解锁
  1885.         '如果仓库改变,清空对应的货区
  1886.         If Index = 1 Then
  1887.             For rjsq = WglrGrid.FixedRows To WglrGrid.Rows - 1
  1888.                WglrGrid.TextMatrix(rjsq, Sydz("005", GridStr(), Szzls)) = ""
  1889.             Next rjsq
  1890.         End If
  1891.      
  1892. End Sub
  1894. Private Sub LrText_GotFocus(Index As Integer)                                                 '文本框得到焦点,显示相应信息
  1895.     Call TextShow(Index)
  1896. End Sub
  1898. Private Sub LrText_KeyDown(Index As Integer, KeyCode As Integer, Shift As Integer)            '字段按F2键提供帮助
  1899.     
  1900.     Select Case KeyCode
  1901.         Case vbKeyF2
  1902.             Call Text_Help(Index)
  1903.     End Select
  1905. End Sub
  1907. Private Sub LrText_KeyPress(Index As Integer, KeyAscii As Integer)                            '文本框录入事中控制
  1908.     Call InputFieldLimit(LrText(Index), Textint(Index, 1), KeyAscii)
  1909. End Sub
  1911. Private Sub LrText_LostFocus(Index As Integer)                                                '文本框失去焦点进行有效性判断及相应处理
  1912.     
  1913.     If Textint(Index, 9) = 0 Or Textint(Index, 9) = 1 Then '事中判断
  1914.         Call TextYxxpd(Index)
  1915.     End If
  1917. End Sub
  1919. Private Sub Ydcommand1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single) '点击按钮
  1920.     Call Text_Help(Ydcommand1.Tag)
  1921. End Sub
  1923. Private Sub Text_Help(Index As Integer)                                                       '录入字段帮助
  1924.     
  1925.     Dim StrType As String
  1926.     
  1927.     If Not Ydcommand1.Visible Then
  1928.         Exit Sub
  1929.     End If
  1930.     TextValiLock = True
  1931.     If OptRed.Value = True Then
  1932.         S1 = "1"
  1933.     Else
  1934.         S1 = "0"
  1935.     End If
  1936.     If Textint(Index, 2) <> 1 Then
  1937.         If Index = 0 Then
  1938.             strHlpR = FunHlpR(Trim(Textstr(Index, 4)), "billtype", S1)
  1939.         Else
  1940.             strHlpR = FunHlpR(Trim(Textstr(Index, 4)), "czybm", Xtczybm)
  1941.         End If
  1942.     End If
  1943.     '如果调收料通知单帮助,当红字时调退货单,篮字时调收料单
  1944.   
  1945.     Call Drbmhelp(Textint(Index, 2), Textstr(Index, 4), Trim(LrText(Index).Text))
  1946.     If Len(Xtfhcs) <> 0 Then
  1947.         If Textint(Index, 3) = 1 Then
  1948.             LrText(Index).Text = Xtfhcsfz
  1949.             LrText(Index).Tag = Xtfhcs
  1950.         Else
  1951.             LrText(Index).Text = Xtfhcs
  1952.             LrText(Index).Tag = Xtfhcsfz
  1953.         End If
  1954.     End If
  1955.     TextValiLock = False
  1956.     LrText(Index).SetFocus
  1958. End Sub
  1960. Private Sub TextShow(Index As Integer)        '文本框得到焦点,显示相应信息
  1962.     '如果文本框有帮助,则显示帮助按钮
  1963.     If Textboolean(Index, 1) Then
  1964.         Ydcommand1.Visible = True
  1965.         Ydcommand1.Move LrText(Index).Left + LrText(Index).Width, LrText(Index).Top
  1966.         Ydcommand1.Tag = Index
  1967.     Else
  1968.         Ydcommand1.Tag = ""
  1969.         Ydcommand1.Visible = False
  1970.     End If
  1971.     
  1972.     '[>>
  1973.     '可在此处定义其他处理动作
  1974.     '<<]
  1976. End Sub
  1978. Private Sub Wbkcsh()                          '录入文本框初始化
  1979.   
  1980.     Dim Int_TabIndex As Integer         'Tab焦点计数器
  1981.     
  1982.     '单据录入中文本框焦点由0开始
  1983.     LrText(0).TabIndex = 0
  1984.   
  1985.     '最大录入文本框索引值
  1986.     Max_Text_Index = Textvar(1)
  1987.   
  1988.     ReDim TextValiJudgeLock(Max_Text_Index)
  1989.     For jsqte = 0 To Max_Text_Index
  1990.         
  1991.         '判断此文本框录入索引号是否存在,如存在则对其进行初始化
  1992.         If Len(Trim(Textstr(jsqte, 1))) <> 0 Then
  1993.         
  1994.             '自动装入录入文本框和其解释标签
  1995.             If jsqte <> 0 Then
  1996.                 Load LrText(jsqte)
  1997.                 Load TsLabel(jsqte)
  1998.             End If
  1999.            
  2000.             '判断录入文本框是否显示
  2001.             If Textboolean(jsqte, 4) Then
  2002.                 LrText(jsqte).Visible = True
  2003.                 TsLabel(jsqte).Visible = True
  2004.             End If
  2005.             
  2006.             '判断文本框是否可编辑
  2007.             If Textboolean(jsqte, 5) Then
  2008.                 LrText(jsqte).Enabled = True
  2009.             Else
  2010.                 LrText(jsqte).Enabled = False
  2011.             End If
  2012.            
  2013.             '初始化其内容
  2014.             TextChangeLock = True
  2015.             LrText(jsqte).Text = ""
  2016.             LrText(jsqte).Tag = ""
  2017.             If Textint(jsqte, 5) <> 0 Then
  2018.                 LrText(jsqte).MaxLength = Textint(jsqte, 5)
  2019.             End If
  2020.             TextChangeLock = False
  2021.         
  2022.             '设置文本框位置及大小,并设置相应标签内容及其位置
  2023.             LrText(jsqte).Move Textint(jsqte, 13), Textint(jsqte, 12), Textint(jsqte, 11), Textint(jsqte, 10)
  2024.             TsLabel(jsqte).Caption = Textstr(jsqte, 7) & ":"
  2025.             TsLabel(jsqte).Move Textint(jsqte, 13) - TsLabel(jsqte).Width - 20, Textint(jsqte, 12) + (Textint(jsqte, 10) - TsLabel(jsqte).Height) / 2 - 30
  2026.             
  2027.         End If
  2028.      
  2029.         '将文本框有效性判断进行加锁,在文本框内容发生变化时将锁打开
  2030.         TextValiJudgeLock(jsqte) = True
  2031.       
  2032.     Next jsqte
  2033.     '设置文本框焦点转移顺序(前提文本焦点从0至Max_Text_Index)
  2034.     For Int_TabIndex = 0 To Max_Text_Index
  2035.         For jsqte = 0 To Max_Text_Index
  2036.             If Textint(jsqte, 14) = Int_TabIndex Then
  2037.                LrText(jsqte).TabIndex = Int_TabIndex
  2038.             End If
  2039.         Next jsqte
  2040.     Next Int_TabIndex
  2041. End Sub
  2043. Private Function TextYxxpd(Index As Integer) As Boolean           '文本框有效性判断
  2044.   
  2045.     Dim Sqlstr As String
  2046.     Dim Findrec As New ADODB.Recordset
  2047.   
  2048.     '按帮助不进行有效性判断
  2049.   
  2050.     If TextValiLock Then
  2051.         TextValiLock = False
  2052.         TextYxxpd = True
  2053.         Exit Function
  2054.     End If
  2055.   
  2056.     '文本框内容未曾改变不进行有效性判断
  2057.   
  2058.     If TextValiJudgeLock(Index) Then
  2059.         Ydcommand1.Visible = False
  2060.         TextYxxpd = True
  2061.         Exit Function
  2062.     End If
  2063.   
  2064.     '文本框内容为空认为有效,并清空其Tag值
  2065.   
  2066.     If Trim(LrText(Index)) = "" Then
  2067.         LrText(Index).Tag = ""
  2068.         Call Wbklrwbcl(Index)
  2069.         Ydcommand1.Visible = False
  2070.         TextValiJudgeLock(Index) = True
  2071.         TextYxxpd = True
  2072.         Exit Function
  2073.     End If
  2074.    
  2075.     '[>>
  2076.       
  2077.     '可在此加入不做有效性判断的理由(参照上面程序)
  2078.       
  2079.     '<<]
  2080.   
  2081.     Select Case Textint(Index, 4)
  2082.         Case 1      '编码型
  2083.             Sqlstr = Trim(Textstr(Index, 5))
  2084.             If Index = 0 Then
  2085.                 If OptRed.Value = True Then
  2086.                     Sqlstr = Sqlstr & " and billType='1'"
  2087.                 Else
  2088.                     Sqlstr = Sqlstr & " and billType='0'"
  2089.                 End If
  2090.                 If Lab_OperStatus = "2" Then
  2091.                     Sqlstr = Sqlstr & " and OutFlag=0"
  2092.                 End If
  2093.             End If
  2094.             Sqlstr = Replace(Sqlstr, "@", "'" + Trim(LrText(Index).Text) + "'")
  2095.             Set Findrec = Cw_DataEnvi.DataConnect.Execute(Sqlstr)
  2096.             If Findrec.EOF Then
  2097.                 Call Xtxxts(Trim(Textstr(Index, 6)), 0, 1)
  2098.                 LrText(Index).SetFocus
  2099.                 Exit Function
  2100.             Else
  2101.                 Select Case Textint(Index, 3)
  2102.                     Case 0
  2103.                         If Len(Trim(Textstr(Index, 2))) <> 0 Then
  2104.                             LrText(Index).Text = Trim(Findrec.Fields(Trim(Textstr(Index, 2))))
  2105.                         End If
  2106.                         If Len(Trim(Textstr(Index, 3) & "")) <> 0 Then
  2107.                             LrText(Index).Tag = Trim(Findrec.Fields(Trim(Textstr(Index, 3))))
  2108.                         End If
  2109.                     Case 1
  2110.                         If Len(Trim(Textstr(Index, 3) & "")) <> 0 Then
  2111.                             LrText(Index).Text = Trim(Findrec.Fields(Trim(Textstr(Index, 3))))
  2112.                         End If
  2113.                         If Len(Trim(Textstr(Index, 2))) <> 0 Then
  2114.                             LrText(Index).Tag = Trim(Findrec.Fields(Trim(Textstr(Index, 2))))
  2115.                         End If
  2116.                 End Select
  2117.             End If
  2118.         Case 2      '日期型
  2119.             If IsDate(LrText(Index).Text) Then
  2120.                 LrText(Index).Text = Format(LrText(Index).Text, "yyyy-mm-dd")
  2121.                 If Val(Mid(LrText(Index), 1, 4)) < 1900 Then
  2122.                     LrText(Index).Text = "1900" + Mid(LrText(Index), 5, 6)
  2123.                 End If
  2124.             Else
  2125.                 Tsxx = "非法公历日期!(格式:" + Format(Date, "yyyy-mm-dd") + ")"
  2126.                 Call Xtxxts(Tsxx, 0, 1)
  2127.                 LrText(Index).SetFocus
  2128.                 Exit Function
  2129.             End If
  2130.         Case 3      '其他类型
  2131.     End Select
  2132.     
  2133.     '隐藏帮助按钮
  2134.     Ydcommand1.Visible = False
  2135.    
  2136.     '如果有效则加锁,用户不改变内容则不再进行有效性判断
  2137.     TextValiJudgeLock(Index) = True
  2139.     '调用文本框事后处理程序
  2140.     Call Wbklrwbcl(Index)
  2141.    
  2142.     '有效性判断通过则返回True
  2143.     TextYxxpd = True
  2144.     
  2145. End Function