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

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

企业管理

开发平台：

Visual Basic

：源码内容
  1.                         Tsxx = "物料编码与第" & int_temp - .FixedRows + 1 & "行分录物料编码重复!"
  2.                         Lrywlz = Sydz("001", GridStr(), Szzls)
  3.                         GoTo Lrcwcl
  4.                     End If
  5.                 End If
  6.                 int_temp = int_temp + 1
  7.             Next int_temp
  8.         
  9.         Next Rowjsq
  11.      
  12.         '单据分录行数不能为零(Fixed)
  13.         If Lng_RowCount = 0 Then
  14.             Tsxx = "单据分录行数不能为零!"
  15.             Call Xtxxts(Tsxx, 0, 1)
  16.             Exit Function
  17.         End If
  18.         
  19.         '[>>
  20.         '此处可以定义整张单据不能通过有效性检查的理由
  21.         '<<]
  22.     End With  '网格
  23.    
  24.    
  25.     '二.=============如果以上有效性检查均顺利通过,则执行存盘动作============'
  26.    
  27.     '对存盘进行事务处理(Fixed)
  28.     On Error GoTo Swcwcl
  29.     Cw_DataEnvi.DataConnect.BeginTrans
  30.     
  31.     '判断单据状态以进行不同处理
  32.     
  33.     '1.先对单据主表进行处理
  34.     If Trim(Lab_OperStatus) = "2" Then
  35.     
  36.         '新增单据
  37.         
  38.         '1.对于某些单据号自动生成的单据则可在此处自动生成
  39.          LrText(1).Text = CreatBillCode(BillCode, True)
  40.     
  41.         '2.开始存盘
  42.          
  43.         '打开单据主表动态集
  44.         If Rec_VouchMain.State = 1 Then Rec_VouchMain.Close
  45.         Rec_VouchMain.Open "Select * From Cg_PurReciptMain Where 1=2", Cw_DataEnvi.DataConnect, adOpenDynamic, adLockOptimistic
  46.              
  47.         With Rec_VouchMain
  48.             .AddNew
  49.             .Fields("PurReciptMainID") = CreatBillID(BillCode)                  '单据ID
  50.             .Fields("PurReciptNum") = Trim(LrText(1).Text)                      '单据号
  51.             .Fields("PurReciptDate") = CDate(LrText(0).Text)                    '退货日期
  52.             .Fields("BillCode") = "1105"                                        '单据编码
  53.             If Trim(LrText(2).Tag) <> "" Then
  54.                 .Fields("ReturnRource") = Trim(LrText(2).Tag)                   '收料通知单ID
  55.                 .Fields("ReturnSourceNum") = Trim(LrText(2).Text)               '收料通知单号
  56.             End If
  57.             If Trim(LrText(3).Tag) <> "" Then
  58.                 .Fields("PurPlanMainID") = Trim(LrText(3).Tag)                  '计划ID
  59.                 .Fields("PurPlanNum") = Trim(LrText(3).Text)                    '计划单号
  60.             End If
  61.             If Trim(LrText(4).Tag) <> "" Then
  62.                 .Fields("OrderFormMainID") = Trim(LrText(4).Tag)                '订单ID
  63.                 .Fields("OrderFormNum") = Trim(LrText(4).Text)                  '订单号
  64.             End If
  65.             If Trim(LrText(5).Tag) <> "" Then
  66.                 .Fields("SupplierCode") = Trim(LrText(5).Tag)                   '供应商编码
  67.             End If
  68.             If Trim(LrText(6).Tag) <> "" Then
  69.                 .Fields("DeptCode") = Trim(LrText(6).Tag)                       '部门编码
  70.             End If
  71.             If Trim(LrText(7).Tag) <> "" Then
  72.                 .Fields("PersonCode") = Trim(LrText(7).Tag)                     '业务员编码
  73.             End If
  74.             If Trim(LrText(8).Tag) <> "" Then
  75.                 .Fields("WhCode") = Trim(LrText(8).Tag)                         '仓库编码
  76.             End If
  77.             If Trim(LrText(9).Tag) <> "" Then
  78.                 .Fields("InOutClassCode") = Trim(LrText(9).Tag)                 '出库类别编码
  79.             End If
  80.             If Trim(LrText(10).Tag) <> "" Then
  81.                 .Fields("TransferWayCode") = Trim(LrText(10).Tag)               '运输方式编码
  82.             End If
  83.             If Trim(LrText(11).Tag) <> "" Then
  84.                 .Fields("TranCompanyCode") = Trim(LrText(11).Tag)               '承运单位名称
  85.             End If
  86.             .Fields("ReturnReason") = Trim(LrText(12).Text)                     '退货原因
  87.             .Fields("Remark") = Trim(LrText(13).Text)                           '备注
  88.             .Fields("KjYear") = Int_Year                                        '会计年
  89.             .Fields("Period") = Int_Period                                      '会计期间
  90.             .Fields("Maker") = Trim(LrText(14).Text)                            '制单人
  91.             .Fields("Checker") = ""                                             '审核人置空
  92.             .Update
  93.             '系统读出单据ID写入Lab_BillID
  94.             Lab_BillId.Caption = .Fields("PurReciptMainID")
  95.         End With
  96.     Else
  97.         '修改单据
  98.        
  99.         
  101.         '1.删除原单据子表中所有内容
  102.         Cw_DataEnvi.DataConnect.Execute ("Delete Cg_PurReciptSub Where PurReciptMainID=" & S2N(Lab_BillId.Caption))
  103.         
  104.         '打开单据主表动态集
  105.         If Rec_VouchMain.State = 1 Then Rec_VouchMain.Close
  106.         Rec_VouchMain.Open "Select * From Cg_PurReciptMain  Where PurReciptMainID=" & S2N(Lab_BillId.Caption), Cw_DataEnvi.DataConnect, adOpenDynamic, adLockOptimistic
  107.         With Rec_VouchMain
  108.             .Fields("PurReciptNum") = Trim(LrText(1).Text)                      '单据号
  109.             .Fields("PurReciptDate") = CDate(LrText(0).Text)                    '退货日期
  110.             If Trim(LrText(2).Tag) <> "" Then
  111.                 .Fields("ReturnRource") = Trim(LrText(2).Tag)                   '收料通知单ID
  112.                 .Fields("ReturnSourceNum") = Trim(LrText(2).Text)               '收料通知单号
  113.             Else
  114.                 .Fields("ReturnRource") = Null
  115.                 .Fields("ReturnSourceNum") = Null
  116.             End If
  117.             
  118.             If Trim(LrText(3).Tag) <> "" Then
  119.                 .Fields("PurPlanMainID") = Trim(LrText(3).Tag)                  '计划ID
  120.                 .Fields("PurPlanNum") = Trim(LrText(3).Text)                    '计划单号
  121.             Else
  122.                 .Fields("PurPlanMainID") = Null
  123.                 .Fields("PurPlanNum") = Null
  124.             End If
  125.             If Trim(LrText(4).Tag) <> "" Then
  126.                 .Fields("OrderFormMainID") = Trim(LrText(4).Tag)                '订单ID
  127.                 .Fields("OrderFormNum") = Trim(LrText(4).Text)                  '订单号
  128.             Else
  129.                 .Fields("OrderFormMainID") = Null
  130.                 .Fields("OrderFormNum") = Null
  131.             End If
  132.             If Trim(LrText(5).Tag) <> "" Then
  133.                 .Fields("SupplierCode") = Trim(LrText(5).Tag)                   '供应商编码
  134.             Else
  135.                 .Fields("SupplierCode") = Null
  136.             End If
  137.             If Trim(LrText(6).Tag) <> "" Then
  138.                 .Fields("DeptCode") = Trim(LrText(6).Tag)                       '部门编码
  139.             Else
  140.                 .Fields("DeptCode") = Null
  141.             End If
  142.             If Trim(LrText(7).Tag) <> "" Then
  143.                 .Fields("PersonCode") = Trim(LrText(7).Tag)                     '业务员编码
  144.             Else
  145.                 .Fields("PersonCode") = Null
  146.             End If
  147.             If Trim(LrText(8).Tag) <> "" Then
  148.                 .Fields("WhCode") = Trim(LrText(8).Tag)                         '仓库编码
  149.             Else
  150.                 .Fields("WhCode") = Null
  151.             End If
  152.             If Trim(LrText(9).Tag) <> "" Then
  153.                 .Fields("InOutClassCode") = Trim(LrText(9).Tag)                 '出库类别编码
  154.             Else
  155.                 .Fields("InOutClassCode") = Null
  156.             End If
  157.             If Trim(LrText(10).Tag) <> "" Then
  158.                 .Fields("TransferWayCode") = Trim(LrText(10).Tag)               '运输方式编码
  159.             Else
  160.                 .Fields("TransferWayCode") = Null
  161.             End If
  162.             If Trim(LrText(11).Tag) <> "" Then
  163.                 .Fields("TranCompanyCode") = Trim(LrText(11).Tag)               '承运单位名称
  164.             Else
  165.                 .Fields("TranCompanyCode") = Null
  166.             End If
  167.             .Fields("ReturnReason") = Trim(LrText(12).Text)                     '退货原因
  168.             .Fields("Remark") = Trim(LrText(13).Text)                           '备注
  169.             .Fields("KjYear") = Int_Year                                        '会计年
  170.             .Fields("Period") = Int_Period                                      '会计期间
  171.             .Fields("Maker") = Trim(LrText(14).Text)                            '制单人
  172.             .Fields("Checker") = ""                                             '审核人置空
  173.             .Update
  174.         End With
  175.     End If
  176.          
  177.     '2.对单据子表进行处理
  178.          
  179.     '打开单据子表动态集
  180.     If Rec_VouchSub.State = 1 Then Rec_VouchSub.Close
  181.     Rec_VouchSub.Open "Select * From Cg_PurReciptSub Where 1=2", Cw_DataEnvi.DataConnect, adOpenDynamic, adLockOptimistic
  182.      
  183.     '将网格中有效数据行写入单据子表
  184.     For Rowjsq = WglrGrid.FixedRows To WglrGrid.Rows - 1
  185.         If WglrGrid.TextMatrix(Rowjsq, 0) <> "*" Then
  186.             Exit For
  187.         End If
  188.         
  189.         With Rec_VouchSub
  190.             .AddNew
  191.             .Fields("PurReciptSubID") = Rowjsq - WglrGrid.FixedRows + 1                                                     '单据记录顺序号
  192.             .Fields("PurReciptMainID") = S2N(Lab_BillId.Caption)                                                            '单据ID
  193.             .Fields("Mnumber") = Trim(WglrGrid.TextMatrix(Rowjsq, Sydz("001", GridStr(), Szzls)))                           '物料编码
  194.             .Fields("BatchNum") = Trim(WglrGrid.TextMatrix(Rowjsq, Sydz("005", GridStr(), Szzls)))                          '批号
  195.             .Fields("Quantity") = (-1) * S2N(WglrGrid.TextMatrix(Rowjsq, Sydz("006", GridStr(), Szzls)))                    '数量
  196.             .Fields("Price") = S2N(WglrGrid.TextMatrix(Rowjsq, Sydz("007", GridStr(), Szzls)))                              '单价
  197.             .Fields("PurReciptMoney") = (-1) * S2N(WglrGrid.TextMatrix(Rowjsq, Sydz("008", GridStr(), Szzls)))              '金额
  198.             .Fields("VehicleNum") = Trim(WglrGrid.TextMatrix(Rowjsq, Sydz("009", GridStr(), Szzls)))                        '车牌号
  199.             
  200.             .Update
  201.         End With
  202.     Next Rowjsq
  204.     
  205.     Cw_DataEnvi.DataConnect.CommitTrans
  206.     
  207.     Sub_SaveBill = True
  208.     Tsxx = "单据存盘完毕! 单据号:" & Trim(LrText(1).Text)
  209.     Call Xtxxts(Tsxx, 0, 4)
  210.     
  211.     '标识单据发生改动
  212.     Bln_BillChange = True
  213.     
  214.     '设置单据改变后的状态
  215.     Lab_OperStatus = "1"
  216.     Call Sub_OperStatus("10")
  217.     Rec_Query.Requery
  218.     Rec_Query.Find "PurReciptMainID=" & S2N(Lab_BillId.Caption)
  219.     
  220.     Exit Function
  222. Swcwcl:       '数据存盘时出现错误
  223.     Cw_DataEnvi.DataConnect.RollbackTrans
  224.     With WglrGrid
  225.         If Err.Number = -2147217887 Then
  226.             Tsxx = "单据中第  " & Trim(Str(Rowjsq - .FixedRows + 1)) & " 条分录录入数据超出允许范围!"
  227.             Call Xtxxts(Tsxx, 0, 1)
  228.             Changelock = True
  229.             .Select Rowjsq, Qslz
  230.             WglrGrid.SetFocus
  231.             Changelock = False
  232.             Exit Function
  233.         Else
  234.             Tsxx = "存盘过程中出现未知错误,程序自动恢复保存前状态!"
  235.             Call Xtxxts(Tsxx, 0, 1)
  236.             Exit Function
  237.         End If
  238.     End With
  240. Lrcwcl:        '录入错误处理(存盘前逐行有效性判断)
  241.     With WglrGrid
  242.         Call Xtxxts("(第 " & Trim(Str(Rowjsq - .FixedRows + 1)) & " 条单据分录)-" & Tsxx, 0, 1)
  243.         Changelock = True
  244.         .Select Rowjsq, Lrywlz
  245.         WglrGrid.SetFocus
  246.         Changelock = False
  247.         Exit Function
  248.     End With
  250. End Function
  252. '选择首张,上张,下张,末张(此4个过程只需用您的单据ID字段名替换"PurReciptMainID"即可)
  253. Private Sub Sub_First()             '首 张
  254.     
  255.     With Rec_Query
  256.         If .RecordCount = 0 Then
  257.             Exit Sub
  258.         End If
  259.         .MoveFirst
  260.         Lab_BillId.Caption = .Fields("PurReciptMainID")
  261.         Call Sub_ShowBill
  262.     End With
  264. End Sub
  266. Private Sub Sub_Prev()             '上 张
  267.     
  268.     With Rec_Query
  269.         If .RecordCount = 0 Then
  270.             Exit Sub
  271.         End If
  272.         If Not .BOF Then
  273.             .MovePrevious
  274.         End If
  275.         If Not .BOF Then
  276.             Lab_BillId.Caption = .Fields("PurReciptMainID")
  277.         Else
  278.             .MoveNext
  279.         End If
  280.         Call Sub_ShowBill
  281.     End With
  283. End Sub
  285. Private Sub Sub_Next()             '下 张
  286.     With Rec_Query
  287.         If .RecordCount = 0 Then
  288.             Exit Sub
  289.         End If
  290.         If Not .EOF Then
  291.             .MoveNext
  292.         End If
  293.         If Not .EOF Then
  294.             Lab_BillId.Caption = .Fields("PurReciptMainID")
  295.         Else
  296.             .MovePrevious
  297.         End If
  298.         Call Sub_ShowBill
  299.     End With
  301. End Sub
  303. Private Sub Sub_Last()              '末 张
  304.     
  305.     With Rec_Query
  306.         If .RecordCount = 0 Then
  307.             Exit Sub
  308.         End If
  309.         .MoveLast
  310.         Lab_BillId.Caption = .Fields("PurReciptMainID")
  311.         Call Sub_ShowBill
  312.     End With
  314. End Sub
  315.     
  316. '[>>===================以下为根据实际业务需要自定义过程区域=============================<<]
  318. '审核,弃审
  319. Private Sub Sub_CheckBill()             '审 核
  320.     Dim Rec_Order As New ADODB.Recordset  '修改在订量
  321.     '判断用户是否有此功能执行权限,如有则写上机日志(进入)
  322.     If Not Security_Log(Str_RightCheck, Xtczybm, 1) Then
  323.         Exit Sub
  324.     End If
  325.     '[>>
  326.     '此处可以写入禁止单据审核的理由
  327.     '<<]
  328. On Error GoTo Err_Execute
  329.     Cw_DataEnvi.DataConnect.BeginTrans
  330.     '将单据写入审核标识
  331.     Cw_DataEnvi.DataConnect.Execute ("Update Cg_PurReciptMain Set Checker='" & Xtczy & "' Where PurReciptMainID=" & S2N(Lab_BillId.Caption))
  332.     '回写订单
  333.     Cw_DataEnvi.DataConnect.Execute ("Cg_sp_PurReciptAssociateOrderForm " & S2N(Lab_BillId.Caption))
  334.     '修改在订量
  335.     If Trim(LrText(4).Text) <> "" Then
  336.         For jsqte = WglrGrid.FixedRows To WglrGrid.Rows - 1
  337.             With Rec_Order
  338.                 If Trim(WglrGrid.TextMatrix(jsqte, Sydz("001", GridStr(), Szzls))) = "" Then
  339.                 Exit For
  340.                 End If
  341.                 If .State = 1 Then .Close
  342.                 .Open "select * from gy_material where MNumber='" & Trim(WglrGrid.TextMatrix(jsqte, Sydz("001", GridStr(), Szzls))) & "'", Cw_DataEnvi.DataConnect, adOpenDynamic, adLockOptimistic
  343.                 .Fields("speakquan") = S2N(.Fields("speakquan")) + S2N(WglrGrid.TextMatrix(jsqte, Sydz("006", GridStr(), Szzls))) * S2N(.Fields("PurInvCon1")) / S2N(.Fields("PurInvCon2"))
  344.                 .Update
  345.             End With
  346.         Next jsqte
  347.     End If
  348.     Cw_DataEnvi.DataConnect.CommitTrans
  349.     
  350.     '写入系统操作员
  351.     LrText(15).Text = Xtczy
  352.     
  353.     '设置审核弃审按钮状态
  354.     Call Sub_CheckStatus
  355.     
  356.     '标识单据发生变化
  357.     Bln_BillChange = True
  358.     Exit Sub
  359. Err_Execute:
  360.         Cw_DataEnvi.DataConnect.RollbackTrans
  361.         Tsxx = "审核过程出现错误，恢复到审核前状态!"
  362.         Call Xtxxts(Tsxx, 0, 4)
  363.         Exit Sub
  364. End Sub
  366. Private Sub Sub_AbandonCheck()          '弃 审
  367.     Dim Rec_Order As New ADODB.Recordset   '修改在订量
  368.     '判断用户是否有此功能执行权限,如有则写上机日志(进入)
  369.     If Not Security_Log(Str_RightCheck, Xtczybm, 1) Then
  370.         Exit Sub
  371.     End If
  372.     '[>>
  373.     '此处可以写入禁止单据弃审的理由
  374.     '被库房调用不能放弃审核
  375.     Str_Temp = " Select * from Gy_InOutMain where  ReceiptId=" & S2N(Lab_BillId.Caption)
  376.     Set Rec_Temp = Cw_DataEnvi.DataConnect.Execute(Str_Temp)
  377.     If Not Rec_Temp.EOF Then
  378.         Tsxx = "此退货通知单已被库存系统使用，不能弃审!"
  379.         Call Xtxxts(Tsxx, 0, 4)
  380.         Exit Sub
  381.     End If
  382.     Set Rec_Temp = Nothing
  383.     
  384.     '<<]
  385. On Error GoTo Err_Execute
  386.     Cw_DataEnvi.DataConnect.BeginTrans
  387.     '将单据清除审核标识
  388.     Cw_DataEnvi.DataConnect.Execute ("Update Cg_PurReciptMain Set Checker='' Where PurReciptMainID=" & S2N(Lab_BillId.Caption))
  389.     '回写订单
  390.     Cw_DataEnvi.DataConnect.Execute ("Cg_sp_PurReciptAssociateOrderForm " & S2N(Lab_BillId.Caption) & ",1")
  391.     '修改在订量
  392.     If Trim(LrText(4).Text) <> "" Then
  393.         For jsqte = WglrGrid.FixedRows To WglrGrid.Rows - 1
  394.             With Rec_Order
  395.                 If Trim(WglrGrid.TextMatrix(jsqte, Sydz("001", GridStr(), Szzls))) = "" Then
  396.                 Exit For
  397.                 End If
  398.                 If .State = 1 Then .Close
  399.                 .Open "select * from gy_material where MNumber='" & Trim(WglrGrid.TextMatrix(jsqte, Sydz("001", GridStr(), Szzls))) & "'", Cw_DataEnvi.DataConnect, adOpenDynamic, adLockOptimistic
  400.                 .Fields("speakquan") = S2N(.Fields("speakquan")) - S2N(WglrGrid.TextMatrix(jsqte, Sydz("006", GridStr(), Szzls))) * S2N(.Fields("PurInvCon1")) / S2N(.Fields("PurInvCon2"))
  401.                 .Update
  402.             End With
  403.         Next jsqte
  404.     End If
  405.     Cw_DataEnvi.DataConnect.CommitTrans
  406.     '清空单据审核人
  407.     LrText(15).Text = ""
  408.     
  409.     '设置审核弃审按钮状态
  410.     Call Sub_CheckStatus
  411.     
  412.     '标识单据发生变化
  413.     Bln_BillChange = True
  414.     Exit Sub
  415. Err_Execute:
  416.         Cw_DataEnvi.DataConnect.RollbackTrans
  417.         Tsxx = "弃审过程出现错误，恢复到弃审前状态!"
  418.         Call Xtxxts(Tsxx, 0, 4)
  419.         Exit Sub
  420. End Sub
  422. Private Function Fun_AllowEdit() As Boolean                      '判断当前单据是否允许编辑或删除
  423.   
  424.     Dim RecTemp As New ADODB.Recordset     '临时使用动态集
  425.     Fun_AllowEdit = False
  426.     Sqlstr = "Select Checker,ChalkitupMan  From Cg_PurReciptMain Where PurReciptMainID=" & S2N(Lab_BillId.Caption)
  427.     Set RecTemp = Cw_DataEnvi.DataConnect.Execute(Sqlstr)
  428.     With RecTemp
  429.         If Not .EOF Then
  430.             If Trim(.Fields("Checker") & "") <> "" Then
  431.                 Tsxx = "该单据已审核确认,不能修改或删除!"
  432.                 Call Xtxxts(Tsxx, 0, 4)
  433.                 Exit Function
  434.             End If
  435.             If Trim(.Fields("ChalkitupMan") & "") <> "" Then
  436.                 Tsxx = "该单据已记帐,不能修改或删除!"
  437.                 Call Xtxxts(Tsxx, 0, 4)
  438.                 Exit Function
  439.             End If
  441.         End If
  442.     End With
  443.     Fun_AllowEdit = True
  445. End Function
  446. '[>>===================以上为根据实际业务需要自定义过程区域=============================<<]
  448. '===================以 下 程 序 为 通 用 部 分 ,一 般 不 需 更 改(程序动作部分)======================='
  449. Private Sub Sub_AdjustGrid()
  450.     
  451.     '调 整 网 格
  452.     With WglrGrid
  453.         '加 1 保持一行录入行
  454.         If .Rows < Pmbcsjhs + .FixedRows + Fzxwghs + 1 Then
  455.             .Rows = Pmbcsjhs + .FixedRows + Fzxwghs + 1
  456.             For jsqte = .FixedRows To .Rows - 1
  457.                 .RowHeight(jsqte) = Sjhgd
  458.             Next jsqte
  459.         End If
  460.         
  461.         '判断是否有辅助行和录入行,如没有则加行
  462.         Do While .TextMatrix(.Rows - 1 - Fzxwghs, 0) = "*"
  463.             .AddItem ""
  464.             .RowHeight(.Rows - 1) = Sjhgd
  465.         Loop
  466.     
  467.     End With
  468.     
  469. End Sub
  470. Private Sub Lrzdbz()                                                      '录入字段帮助
  471.     
  472.     If Not Ydcommand.Visible Then
  473.         Exit Sub
  474.     End If
  475.    
  476.     With WglrGrid
  477.         Valilock = True
  478.     
  479.         '处理通用部分
  480.         Changelock = True        '调入另外窗体必须加锁
  481.         Call Drbmhelp(GridInt(.Col, 6), GridStr(.Col, 3), Trim(Ydtext.Text))
  482.         Changelock = False
  483.         
  484.         If Len(Xtfhcs) <> 0 Then
  485.             If GridInt(.Col, 7) = 0 Then
  486.                 Ydtext.Text = Xtfhcs
  487.             Else
  488.                 Ydtext.Text = Xtfhcsfz
  489.             End If
  490.         End If
  491.         
  492.         Valilock = False
  493.         If Ydtext.Visible Then
  494.             Ydtext.SetFocus
  495.         End If
  496.     End With
  498. End Sub
  500. Private Sub Cshhjwg()                                                     '初始化合计网格(*对合计网格来说,录入网格为容器)
  501.     
  502.     With HjGrid
  503.     
  504.        '是否显示合计网格
  505.        If Not Sfxshjwg Then
  506.            .Visible = False
  507.            Exit Sub
  508.        Else
  509.            .Visible = True
  510.        End If
  511.       
  512.        '设置网格相关属性
  513.        .Enabled = False
  514.        .Appearance = flexFlat
  515.        .BorderStyle = flexBorderNone
  516.        .ScrollBars = flexScrollBarNone
  517.        .Width = WglrGrid.Width
  518.        .FixedRows = 0
  519.        .Rows = 1
  520.        .Cols = WglrGrid.Cols
  521.        .LeftCol = WglrGrid.LeftCol
  522.        .TextMatrix(0, Qslz) = "合  计"
  523.        For jsqte = 0 To WglrGrid.Cols - 1
  524.            .ColHidden(jsqte) = WglrGrid.ColHidden(jsqte)
  525.            .ColWidth(jsqte) = WglrGrid.ColWidth(jsqte)
  526.            .ColAlignment(jsqte) = WglrGrid.ColAlignment(jsqte)
  527.            .ColFormat(jsqte) = WglrGrid.ColFormat(jsqte)
  528.        Next jsqte
  529.        .ColAlignment(Qslz) = flexAlignCenterTop
  530.        For jsqte = .FixedRows To .Rows - 1
  531.            .RowHeight(jsqte) = .Height / .Rows
  532.        Next jsqte
  533.        
  534.       '程序自动调整网格高度(自动设置为网格剩余高度+辅助项网格行数(默认为1)*数据行高度)、并设置其位置信息
  535.        .Height = Fzxwghs * Sjhgd + ((WglrGrid.Height - WglrGrid.FixedRows * WglrGrid.RowHeight(0)) Mod Sjhgd)
  536.        .RowHeight(0) = .Height
  537.        .Move 0, WglrGrid.Height - .Height, WglrGrid.Width, .Height
  538.     End With
  540. End Sub
  542. Private Sub Form_Resize()                                                '窗体大小发生变化时,重新显示文本框
  543.    Call Cxxswbk
  544. End Sub
  546. Private Function Fun_Drfrmyxxpd() As Boolean                             '调入其它窗体或功能产生的有效性判断(包括数据回写)
  547.     Fun_Drfrmyxxpd = True
  548.     With WglrGrid
  549.    
  550.         '如果当前网格处于编辑状态,则先进行数据回写再进行有效性判断
  551.         If Ydtext.Visible Or YdCombo.Visible Then
  552.             Call Lrsjhx
  553.             If Not sjzdyxxpd(Dqlrwgh, Dqlrwgl) Then
  554.                 Fun_Drfrmyxxpd = False
  555.                 Exit Function
  556.             End If
  557.         End If
  558.    
  559.         '进行行有效性判断
  560.         If Not Sjhzyxxpd(.Row) Then
  561.             Fun_Drfrmyxxpd = False
  562.             Exit Function
  563.         End If
  564.     End With
  566. End Function
  568. Private Sub WglrGrid_AfterUserResize(ByVal Row As Long, ByVal Col As Long)       '调整列宽
  569.     
  570.     If HjGrid.Visible Then
  571.         With HjGrid
  572.             .ColWidth(Col) = WglrGrid.ColWidth(Col)
  573.         End With
  574.     End If
  576. End Sub
  578. Private Sub WglrGrid_EnterCell()                                                 '显示当前数据行相关信息
  579.     
  580.     With WglrGrid
  581.         If .Row >= .FixedRows Then
  582.             '[>>
  583.             '此处可以填写显示与此网格行相关信息
  584.             '<<]
  585.         End If
  586.     End With
  588. End Sub
  590. Private Sub WglrGrid_GotFocus()                                     '网格得到焦点
  592.     '网格得到焦点,如果当前选择行为非数据行
  593.     '则调整当前焦点至有效数据行
  595.     With WglrGrid
  596.         If .Row < .FixedRows And .Rows > .FixedRows Then
  597.             Changelock = True
  598.             .Select .FixedRows, .Col
  599.             Changelock = False
  600.         End If
  601.         If .Col < Qslz Then
  602.             Changelock = True
  603.             .Select .Row, Qslz
  604.             Changelock = False
  605.         End If
  606.     End With
  608. End Sub
  610. Private Sub WglrGrid_LostFocus()                                    '录入网格失去焦点
  612.     '用以屏蔽调用其它窗体时发生网格失去焦点事件
  613.     If Changelock Then
  614.         Exit Sub
  615.     End If
  617.     '引发网格RowcolChange事件
  618.     With WglrGrid
  619.         If Not (Ydtext.Visible Or YdCombo.Visible) Then
  620.             .Select 0, 0
  621.         End If
  622.     End With
  624. End Sub
  626. Private Sub WglrGrid_AfterScroll(ByVal OldTopRow As Long, ByVal OldLeftCol As Long, ByVal NewTopRow As Long, ByVal NewLeftCol As Long)                                       '限制用户在录入过程中滚动鼠标
  628.     If Gdtlock Then
  629.         Exit Sub
  630.     End If
  631.  
  632.     With WglrGrid
  633.         If Ydtext.Visible Or YdCombo.Visible Then
  634.             Gdtlock = True
  635.             .TopRow = Dqtoprow
  636.             .LeftCol = Dqleftcol
  637.             Gdtlock = False
  638.             Exit Sub
  639.         End If
  640.         HjGrid.LeftCol = .LeftCol
  641.     End With
  643. End Sub
  645. Private Sub WglrGrid_LeaveCell()                                    '离开单元格
  646.     
  647.     If Changelock Then
  648.         Exit Sub
  649.     End If
  651.     '记录刚刚离开网格单元的行列值
  652.     Dqlkwgh = WglrGrid.Row
  653.     Dqlkwgl = WglrGrid.Col
  655.     '判断是否需要录入数据回写
  656.     If Not (Ydtext.Visible Or YdCombo.Visible) Then
  657.         Exit Sub
  658.     End If
  659.     Call Lrsjhx
  661. End Sub
  663. Private Sub WglrGrid_RowColChange()                                '网格录入行列发生变化时,进行有效性判断
  664.     Valilock = True       '屏蔽文本框失去焦点进行有效性判断
  665.     With WglrGrid
  666.         If Changelock Then
  667.             Exit Sub
  668.         End If
  669.         If Not sjzdyxxpd(Dqlrwgh, Dqlrwgl) Then
  670.             Exit Sub
  671.         End If
  672.         If .Row <> Dqlkwgh Then
  673.             If Not Sjhzyxxpd(Dqlkwgh) Then
  674.                 Exit Sub
  675.             End If
  676.         End If
  677.     End With
  678.    
  679.     Call fhyxh
  680.     Call Xldql
  681.    
  682. End Sub
  684. Private Sub WglrGrid_DblClick()          '鼠标双击网格显示文本框
  685.   
  686.     With WglrGrid
  687.         Call xswbk
  688.     End With
  690. End Sub
  692. Private Sub Ycwbk()                      '隐藏文本框,帮助按钮,列表组合框
  693.     
  694.     Valilock = True
  695.     Ydtext.Visible = False
  696.     YdCombo.Visible = False
  697.     Ydcommand.Visible = False
  699. End Sub
  701. Private Sub YdCombo_KeyDown(KeyCode As Integer, Shift As Integer)        '列表框移动
  702.     With WglrGrid
  703.         Select Case KeyCode
  704.             Case vbKeyEscape                'ESC 键放弃录入
  705.                 Valilock = True
  706.                 .SetFocus
  707.                 Call Ycwbk
  708.                 Valilock = False
  709.             Case vbKeyReturn                '回 车 键 =13
  710.                 KeyCode = 0
  711.                 .SetFocus
  712.                 Call Lrsjhx
  713.                 Rowjsq = .Row
  714.                 Coljsq = .Col + 1
  715.                 If Coljsq > .Cols - 1 Then
  716.                     If Rowjsq < .Rows - 1 Then
  717.                         Rowjsq = Rowjsq + 1
  718.                     End If
  719.                     Coljsq = Qslz
  720.                 End If
  721.                 Do While Rowjsq <= .Rows - 1
  722.                     If .ColHidden(Coljsq) Or (Not GridBoolean(Coljsq, 1)) Then
  723.                         Coljsq = Coljsq + 1
  724.                         If Coljsq > .Cols - 1 Then
  725.                             Rowjsq = Rowjsq + 1
  726.                             Coljsq = Qslz
  727.                         End If
  728.                     Else
  729.                         Exit Do
  730.                     End If
  731.                 Loop
  732.                 .Select Rowjsq, Coljsq
  733.             Case vbKeyLeft                  '左 箭 头 =37
  734.                 If .Col - 1 = Qslz Then
  735.                     If .ColHidden(Qslz) Or (Not GridBoolean(Qslz, 1)) Then
  736.                         GoTo jzzx
  737.                     End If
  738.                 End If
  739.                 If .Col > Qslz Then
  740.                     KeyCode = 0
  741.                     .SetFocus
  742.                     Call Lrsjhx
  743.                     Coljsq = .Col - 1
  744.                     Do While Coljsq > Qslz
  745.                         If Coljsq - 1 = Qslz Then
  746.                             If .ColHidden(Qslz) Or (Not GridBoolean(Qslz, 1)) Then
  747.                                 GoTo jzzx
  748.                             End If
  749.                         End If
  750.                         If .ColHidden(Coljsq) Or (Not GridBoolean(Coljsq, 1)) Then
  751.                             Coljsq = Coljsq - 1
  752.                         Else
  753.                             Exit Do
  754.                         End If
  755.                     Loop
  756.                     .Select .Row, Coljsq
  757.                 End If
  758.             Case vbKeyRight                 '右 箭 头 =39
  759.                 KeyCode = 0
  760.                 .SetFocus
  761.                 Call Lrsjhx
  762.                 Rowjsq = .Row
  763.                 Coljsq = .Col + 1
  764.                 If Coljsq > .Cols - 1 Then
  765.                     If Rowjsq < .Rows - 1 Then
  766.                         Rowjsq = Rowjsq + 1
  767.                     End If
  768.                     Coljsq = Qslz
  769.                 End If
  770.                 Do While Rowjsq <= .Rows - 1
  771.                     If .ColHidden(Coljsq) Or (Not GridBoolean(Coljsq, 1)) Then
  772.                         Coljsq = Coljsq + 1
  773.                         If Coljsq > .Cols - 1 Then
  774.                             Rowjsq = Rowjsq + 1
  775.                             Coljsq = Qslz
  776.                         End If
  777.                     Else
  778.                         Exit Do
  779.                     End If
  780.                 Loop
  781.                 .Select Rowjsq, Coljsq
  782.         Case Else
  783.    End Select
  784.    
  785. jzzx:
  786.    
  787.     End With
  789. End Sub
  791. Private Sub YdCombo_LostFocus()
  792.   
  793.     With WglrGrid                                    '因为选中网格会先发生Rowcolchange事件置Valiock
  794.         If Not Valilock Then                           '为TRUE
  795.             Call Lrsjhx
  796.             If Not Sjhzyxxpd(Dqlrwgh) Then
  797.                 Exit Sub
  798.             End If
  799.         End If
  800.     End With
  802. End Sub
  804. Private Sub Ydcommand_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
  805.     Call Lrzdbz
  806. End Sub
  808. Private Sub ydtext_KeyDown(KeyCode As Integer, Shift As Integer)
  809.     Dim Rowjsq As Long, Coljsq As Long
  810.     With WglrGrid
  811.         Select Case KeyCode
  812.             Case vbKeyF2
  813.                 Call Lrzdbz
  814.             Case vbKeyEscape                'ESC 键放弃录入
  815.                 Valilock = True
  816.                 Call Ycwbk
  817.                 .SetFocus
  818.             Case vbKeyReturn                '回 车 键 =13
  819.                 KeyCode = 0
  820.                 .SetFocus
  821.                 Call Lrsjhx
  822.                 Rowjsq = .Row
  823.                 Coljsq = .Col + 1
  824.                 If Coljsq > .Cols - 1 Then
  825.                     If Rowjsq < .Rows - 1 Then
  826.                         Rowjsq = Rowjsq + 1
  827.                     End If
  828.                     Coljsq = Qslz
  829.                 End If
  830.                 Do While Rowjsq <= .Rows - 1
  831.                     If .ColHidden(Coljsq) Or (Not GridBoolean(Coljsq, 1)) Then
  832.                         Coljsq = Coljsq + 1
  833.                         If Coljsq > .Cols - 1 Then
  834.                             Rowjsq = Rowjsq + 1
  835.                             Coljsq = Qslz
  836.                         End If
  837.                     Else
  838.                         Exit Do
  839.                     End If
  840.                 Loop
  841.                 If Rowjsq <= .Rows - 1 Then
  842.                     .Select Rowjsq, Coljsq
  843.                 End If
  844.             Case vbKeyUp                    '上 箭 头 =38
  845.                 KeyCode = 0
  846.                 .SetFocus
  847.                 Call Lrsjhx
  848.                 If .Row > .FixedRows Then
  849.                     .Row = .Row - 1
  850.                 End If
  851.             Case vbKeyDown                  '下 箭 头 =40
  852.                 KeyCode = 0
  853.                 .SetFocus
  854.                 Call Lrsjhx
  855.                 If .Row < .Rows - 1 Then
  856.                     .Row = .Row + 1
  857.                 End If
  858.             Case vbKeyLeft                  '左 箭 头 =37
  859.                 If .Col - 1 = Qslz Then
  860.                     If .ColHidden(Qslz) Or (Not GridBoolean(Qslz, 1)) Then
  861.                         GoTo jzzx
  862.                     End If
  863.                 End If
  864.                 If Ydtext.SelStart = 0 And .Col > Qslz Then
  865.                     KeyCode = 0
  866.                     .SetFocus
  867.                     Call Lrsjhx
  868.                     Coljsq = .Col - 1
  869.                     Do While Coljsq > Qslz
  870.                         If Coljsq - 1 = Qslz Then
  871.                             If .ColHidden(Qslz) Or (Not GridBoolean(Qslz, 1)) Then
  872.                                 GoTo jzzx
  873.                             End If
  874.                         End If
  875.                         If .ColHidden(Coljsq) Or (Not GridBoolean(Coljsq, 1)) Then
  876.                             Coljsq = Coljsq - 1
  877.                         Else
  878.                             Exit Do
  879.                         End If
  880.                     Loop
  881.                     .Select .Row, Coljsq
  882.                 End If
  883. jzzx:
  884.             Case vbKeyRight                 '右 箭 头 =39
  885.                 wblong = Len(Ydtext.Text)
  886.                 If (Ydtext.SelStart = wblong Or Ydtext.SelLength = wblong) Then
  887.                     KeyCode = 0
  888.                     .SetFocus
  889.                     Call Lrsjhx
  890.                     Rowjsq = .Row
  891.                     Coljsq = .Col + 1
  892.                     If Coljsq > .Cols - 1 Then
  893.                         If Rowjsq < .Rows - 1 Then
  894.                             Rowjsq = Rowjsq + 1
  895.                         End If
  896.                         Coljsq = Qslz
  897.                     End If
  898.                     Do While Rowjsq <= .Rows - 1
  899.                         If .ColHidden(Coljsq) Or (Not GridBoolean(Coljsq, 1)) Then
  900.                             Coljsq = Coljsq + 1
  901.                             If Coljsq > .Cols - 1 Then
  902.                                 Rowjsq = Rowjsq + 1
  903.                                 Coljsq = Qslz
  904.                             End If
  905.                         Else
  906.                             Exit Do
  907.                         End If
  908.                     Loop
  909.                     .Select Rowjsq, Coljsq
  910.                 End If
  911.             Case Else
  912.         End Select
  913.     End With
  915. End Sub
  917. Private Sub ydtext_KeyPress(KeyAscii As Integer)         '录入字符事中控制
  918.     
  919.     Call InputFieldLimit(Ydtext, GridInt(WglrGrid.Col, 1), KeyAscii)
  920.     If KeyAscii <> 0 Then
  921.         Call Xyxhbz(Dqlrwgh)
  922.     End If
  924. End Sub
  926. Private Sub ydtext_Change()                              '录入事中变化处理
  928.     '防止程序改变但不进行处理
  930.     If Wbkbhlock Then
  931.         Exit Sub
  932.     End If
  934.     With WglrGrid
  935.         '限制字段录入长度
  936.         Wbkbhlock = True
  937.         Call TextChangeLimit(Ydtext, GridInt(.Col, 1))  '去掉无效字符
  938.         Select Case GridInt(.Col, 1)
  939.             Case 8, 11   '金额型
  940.                 Call Sjgskz(Ydtext, Xtjezws - Xtjexsws - 1, Xtjexsws)
  941.             Case 9, 12   '数量型
  942.                 Call Sjgskz(Ydtext, Xtslzws - Xtslxsws - 1, Xtslxsws)
  943.             Case 10      '单价型
  944.                 Call Sjgskz(Ydtext, Xtdjzws - Xtdjxsws - 1, Xtdjxsws)
  945.             Case Else    '其他类型
  946.                 If GridInt(.Col, 3) <> 0 Or GridInt(.Col, 4) <> 0 Then
  947.                     Call Sjgskz(Ydtext, GridInt(.Col, 3), GridInt(.Col, 4))
  948.                 End If
  949.         End Select
  950.         Wbkbhlock = False
  951.     End With
  953. End Sub
  955. Private Sub ydtext_LostFocus()            '如果由于选中网格之外的控件而发生有效性判断(选中网格会先发生Rowcolchange事件置Valiock为TRUE)
  956.   
  957.     With WglrGrid
  958.         If Not Valilock Then
  959.             Call Lrsjhx
  960.             If Not sjzdyxxpd(Dqlrwgh, Dqlrwgl) Then
  961.                 Exit Sub
  962.             End If
  963.             If Not Sjhzyxxpd(Dqlrwgh) Then
  964.                 Exit Sub
  965.             End If
  966.         End If
  967.     End With
  969. End Sub
  971. Private Sub xswbk()                       '在当前选中单元显示文本框,列表框,帮助按钮(通用)
  972.     
  973.     Dim Wbkpy As Integer, Wbkpy1 As Integer '文本框偏移量
  974.   
  975.     '当某种条件成立时禁止文本框激活使单据处于录入状态
  976.     If Not Fun_AllowInput Then
  977.         Exit Sub
  978.     End If
  979.   
  980.     '显示文本框前返回有效行列（解决滚动条问题）
  981.     Call Xldqh
  982.     Call Xldql
  983.   
  984.     '隐藏文本框,帮助按钮,列表组合框
  985.     Call Ycwbk
  986.   
  987.     With WglrGrid
  988.         Dqlrwgh = .Row
  989.         Dqlrwgl = .Col
  990.         If Not GridBoolean(.Col, 1) Or .Row < .FixedRows Then
  991.             Exit Sub
  992.         End If
  993.      
  994.         Wbkpy = 30
  995.         Wbkpy1 = 15
  996.         On Error Resume Next
  997.         If GridBoolean(.Col, 3) Then
  998.             YdCombo.Left = .CellLeft + .Left + Wbkpy
  999.             YdCombo.Top = .CellTop + .Top + Wbkpy
  1000.             YdCombo.Width = .CellWidth - Wbkpy1
  1001.             Call Wbkcl
  1002.             YdCombo.Visible = True
  1003.             YdCombo.SetFocus
  1004.             Ydcommand.Visible = False
  1005.             Ydtext.Visible = False
  1006.         Else
  1007.             If GridBoolean(.Col, 2) Then
  1008.                 Ydcommand.Left = .Left + .CellLeft + .CellWidth - Ydcommand.Width + Wbkpy
  1009.                 Ydcommand.Top = .Top + .CellTop + .CellHeight - Ydcommand.Height + Wbkpy
  1010.                 Ydcommand.Visible = True
  1011.             Else
  1012.                 Ydcommand.Visible = False
  1013.             End If
  1014.              
  1015.             Ydtext.Left = .CellLeft + .Left + Wbkpy
  1016.             Ydtext.Top = .CellTop + .Top + Wbkpy
  1017.             If Ydcommand.Visible Then
  1018.                 If Sfblbzkd Then
  1019.                     Ydtext.Width = .CellWidth - Ydcommand.Width
  1020.                 Else
  1021.                     Ydtext.Width = .CellWidth - Wbkpy1
  1022.                 End If
  1023.             Else
  1024.                 Ydtext.Width = .CellWidth - Wbkpy1
  1025.             End If
  1026.             Ydtext.Height = .CellHeight - Wbkpy1
  1027.         
  1028.             If GridInt(.Col, 2) <> 0 Then
  1029.                 Ydtext.MaxLength = GridInt(.Col, 2)
  1030.             Else
  1031.                 Ydtext.MaxLength = 3000
  1032.             End If
  1033.       
  1034.             Call Wbkcl
  1035.       
  1036.             Ydtext.Visible = True
  1037.             Ydtext.SetFocus
  1038.         End If
  1039.         Dqtoprow = .TopRow
  1040.         Dqleftcol = .LeftCol
  1041.         
  1042.         '重置锁值
  1043.         Valilock = False
  1044.         Wbkbhlock = False
  1045.     End With
  1047. End Sub
  1049. Private Function Fun_AllowInput() As Boolean                           '当某种条件成立时禁止文本框激活使单据处于录入状态
  1050.    
  1051.     '如果单据操作状态为浏览状态则不能显示录入载体(通用)
  1052.     If Trim(Lab_OperStatus.Caption) = "1" Then
  1053.         Exit Function
  1054.     End If
  1055.    
  1056.     '[>>
  1057.     
  1058.     '此处可以填写禁止文本框激活使单据处于录入状态的理由
  1059.    
  1060.     '<<]
  1061.    
  1062.     Fun_AllowInput = True
  1064. End Function
  1066. Private Sub Cxxswbk()                                                  'Formresize中重新显示文本框,列表框,帮助按钮(通用)
  1067.                    
  1068.     Dim Wbkpy As Integer, Wbkpy1 As Integer
  1069.     Wbkpy = 30
  1070.     Wbkpy1 = 15
  1071.     With WglrGrid
  1072.         If YdCombo.Visible Then
  1073.             YdCombo.Left = .CellLeft + .Left + Wbkpy
  1074.             YdCombo.Top = .CellTop + .Top + Wbkpy
  1075.             YdCombo.Width = .CellWidth - Wbkpy1
  1076.         End If
  1077.         If Ydcommand.Visible Then
  1078.             Ydcommand.Left = .Left + .CellLeft + .CellWidth - Ydcommand.Width + Wbkpy
  1079.             Ydcommand.Top = .Top + .CellTop + .CellHeight - Ydcommand.Height + Wbkpy
  1080.         End If
  1081.         If Ydtext.Visible Then
  1082.             If Ydcommand.Visible Then
  1083.                 If Sfblbzkd Then
  1084.                     Ydtext.Width = .CellWidth - Ydcommand.Width
  1085.                 Else
  1086.                     Ydtext.Width = .CellWidth - Wbkpy1
  1087.                 End If
  1088.             Else
  1089.                 Ydtext.Width = .CellWidth - Wbkpy1
  1090.             End If
  1091.             Ydtext.Left = .CellLeft + .Left + Wbkpy
  1092.             Ydtext.Top = .CellTop + .Top + Wbkpy
  1093.             Ydtext.Height = .CellHeight - Wbkpy1
  1094.         End If
  1095.     End With
  1097. End Sub
  1099. Private Sub Lrsjhx()                                                   '文本框录入数据回写
  1100.     
  1101.     With WglrGrid
  1102.         If YdCombo.Visible Then
  1103.             .Text = Trim(YdCombo.Text)
  1104.         End If
  1105.         If Ydtext.Visible Then
  1106.             .Text = Trim(Ydtext.Text)
  1107.         End If
  1108.         
  1109.         '(如果字段录入内容发生变化,则打开有效性判断锁)
  1110.         If Zdlrqnr <> Trim(.Text) Then
  1111.             Yxxpdlock = False
  1112.             Hyxxpdlock = False
  1113.         End If
  1114.     
  1115.         '如果字段录入内容不为空则写数据行有效性标志
  1116.         If Len(Trim(.Text)) <> 0 Then
  1117.             Call Xyxhbz(.Row)
  1118.         End If
  1119.     
  1120.         '隐藏文本框,帮助按钮,列表组合框
  1121.         Call Ycwbk
  1122.     End With
  1124. End Sub
  1126. Private Sub WglrGrid_KeyDown(KeyCode As Integer, Shift As Integer)    '网格录入增行，删行快捷键
  1127.   
  1128.     '如果单据操作状态为浏览状态则不能显示录入载体
  1129.     If Trim(Lab_OperStatus.Caption) = "1" Then
  1130.         Exit Sub
  1131.     End If
  1133.     Select Case KeyCode
  1134.         Case vbKeyF2                   '按F2键参照
  1135.             Call xswbk
  1136.             Call Lrzdbz
  1137.         Case vbKeyDelete               '删行
  1138.             Call Scdqfl
  1139.         Case vbKeyInsert               '增行
  1140.             Call zjlrfl
  1141.     End Select
  1143. End Sub
  1145. Private Sub WglrGrid_KeyPress(KeyAscii As Integer)                             '网格接受键盘录入
  1147.     '当某种条件成立时禁止文本框激活使单据处于录入状态
  1148.     If Not Fun_AllowInput Then
  1149.         Exit Sub
  1150.     End If
  1151.   
  1152.     With WglrGrid
  1153.         '屏 蔽 回 车 键
  1154.         If KeyAscii = vbKeyReturn Then
  1155.             KeyAscii = 0
  1156.             Rowjsq = .Row
  1157.             Coljsq = .Col + 1
  1158.             If Coljsq > .Cols - 1 Then
  1159.                 If Rowjsq < .Rows - 1 Then
  1160.                     Rowjsq = Rowjsq + 1
  1161.                 End If
  1162.                 Coljsq = Qslz
  1163.             End If
  1164.             Do While Rowjsq <= .Rows - 1
  1165.                 If .ColHidden(Coljsq) Or (Not GridBoolean(Coljsq, 1)) Then
  1166.                     Coljsq = Coljsq + 1
  1167.                     If Coljsq > .Cols - 1 Then
  1168.                         Rowjsq = Rowjsq + 1
  1169.                         Coljsq = Qslz
  1170.                     End If
  1171.                 Else
  1172.                     Exit Do
  1173.                 End If
  1174.             Loop
  1175.             If Rowjsq <= .Rows - 1 Then
  1176.                 .Select Rowjsq, Coljsq
  1177.             End If
  1178.             Exit Sub
  1179.         End If
  1180.      
  1181.         '接受用户录入
  1182.         Select Case KeyAscii
  1183.             Case 0 To 32             '用户输入KeyAscii为0-32的键 如空格
  1184.                 '显示录入载体
  1185.                 Call xswbk
  1186.             Case Else
  1187.                 '防止非编辑字段SendKeys()出现死循环
  1188.                 If Not GridBoolean(.Col, 1) Or .Row < .FixedRows Then
  1189.                     Exit Sub
  1190.                 End If
  1191.                 '如果此字段为列表框录入则调入相应列表框
  1192.                 If GridBoolean(.Col, 3) Then
  1193.                     '列表框录入
  1194.                     Call xswbk
  1195.                 Else
  1196.                     Ydtext.Text = ""
  1197.                     '录入限制
  1198.                     Call InputFieldLimit(Ydtext, GridInt(WglrGrid.Col, 1), KeyAscii)
  1199.                     If KeyAscii = 0 Then
  1200.                         Exit Sub
  1201.                     End If
  1202.                     '如果录入字符有效则写有效行数据标志
  1203.                     Call Xyxhbz(.Row)
  1204.                     Call xswbk
  1205.                     Ydtext.Text = ""
  1206.                     Valilock = True
  1207.                     SendKeys Chr(KeyAscii), True
  1208.                     DoEvents
  1209.                     Valilock = False
  1210.                 End If
  1211.         End Select
  1212.     End With
  1214. End Sub
  1216. Private Sub zjlrfl()                                                    '增加录入分录
  1217.     
  1218.     With WglrGrid
  1219.         If Not (Ydtext.Visible Or YdCombo.Visible) Then
  1220.             If Not Fun_Drfrmyxxpd Then
  1221.                 Exit Sub
  1222.             End If
  1223.         Else
  1224.             Exit Sub
  1225.         End If
  1226.         If .Row < .FixedRows Then
  1227.             Exit Sub
  1228.         End If
  1229.         .AddItem "", .Row
  1230.         .RowHeight(.Row) = Sjhgd
  1231.         If .Row <> .Rows - 1 Then
  1232.             If .TextMatrix(.Row + 1, 0) = "*" Then
  1233.                 .TextMatrix(.Row, 0) = "*"
  1234.             Else
  1235.                 .RemoveItem .Rows - 1
  1236.             End If
  1237.         End If
  1238.         Call Xldqh
  1239.         Call Xldql
  1240.         Hyxxpdlock = False
  1241.     End With
  1243. End Sub
  1245. Private Sub Scdqfl()                                                    '删除当前分录
  1246.     Dim Answer As Integer, Scqwghz As Long, Scqwglz As Long, Hjlzte As Long, Sflrzt As Boolean
  1247.     With WglrGrid
  1248.         Scqwghz = .Row
  1249.         Scqwglz = .Col
  1250.         If .TextMatrix(.Row, 0) = "*" Then
  1251.             '判断是否为录入状态
  1252.             If Ydtext.Visible Or YdCombo.Visible Then
  1253.                 Sflrzt = True
  1254.                 Validate = True
  1255.                 Call Lrsjhx
  1256.                 Validate = False
  1257.             End If
  1258.             Call Xldqh
  1259.             Changelock = True
  1260.             .Select .Row, 0
  1261.             Changelock = False
  1262.             If Shsfts Then
  1263.                 .Cell(flexcpBackColor, .Row, Qslz, .Row, .Cols - 1) = QBColor(12)
  1264.                 Tsxx = "请确认是否删除当前记录?"
  1265.                 yhAnswer = Xtxxts(Tsxx, 2, 2)
  1266.                 If yhAnswer = 2 Then
  1267.                     .Cell(flexcpBackColor, .Row, Qslz, .Row, .Cols - 1) = &H80000005
  1268.                     Changelock = True
  1269.                     .Select Scqwghz, Scqwglz
  1270.                     Changelock = False
  1271.                     
  1272.                     '如为录入状态,则恢复录入
  1273.                     If Sflrzt Then
  1274.                         Call xswbk
  1275.                     End If
  1276.                     Exit Sub
  1277.                 End If
  1278.             End If
  1279.             .RemoveItem .Row
  1280.             If .Rows < Pmbcsjhs + .FixedRows + Fzxwghs + 1 Then
  1281.                 .AddItem ""
  1282.                 .RowHeight(.Rows - 1) = Sjhgd
  1283.             End If
  1284.             Changelock = True
  1285.             .Select .Row, Scqwglz
  1286.             Changelock = False
  1287.    
  1288.             '重新计算合计数据
  1289.             For Hjlzte = Qslz To .Cols - 1
  1290.                 Call Sjhj(Hjlzte)
  1291.             Next Hjlzte
  1292.         End If
  1293.     End With
  1295. End Sub
  1297. Private Sub Sjhj(Hjwgl As Long)                                         '网格列数据合计
  1298.     
  1299.     Dim Hjjg As Double
  1300.     If Not (GridBoolean(Hjwgl, 4)) Then
  1301.         Exit Sub
  1302.     End If
  1303.     With WglrGrid
  1304.         Hjjg = 0
  1305.         For jsqte = .FixedRows To .Rows - 1
  1306.             If .TextMatrix(jsqte, 0) = "*" Then
  1307.                 Hjjg = Hjjg + S2N(.TextMatrix(jsqte, Hjwgl))
  1308.             End If
  1309.         Next jsqte
  1310.         If GridBoolean(Hjwgl, 5) And Hjjg = 0 Then
  1311.             HjGrid.TextMatrix(0, Hjwgl) = ""
  1312.         Else
  1313.             HjGrid.TextMatrix(0, Hjwgl) = Hjjg
  1314.         End If
  1315.     End With
  1317. End Sub
  1319. Private Sub Qkwlzd(sjh As Long, Sjl As Long)                            '清空为零字段
  1320.     
  1321.     If Not GridBoolean(Sjl, 5) Then
  1322.         Exit Sub
  1323.     End If
  1324.     With WglrGrid
  1325.         If S2N(Trim(.TextMatrix(sjh, Sjl))) = 0 Then
  1326.             .TextMatrix(sjh, Sjl) = ""
  1327.         End If
  1328.     End With
  1330. End Sub
  1332. Private Sub fhyxh()                                                     '返回录入数据有效行,同时让得到焦点网格可见
  1333.     
  1334.     With WglrGrid
  1335.         If .Row >= .FixedRows Then
  1336.             If .TextMatrix(.Row, 0) <> "*" Then
  1337.                 For Rowjsq = .FixedRows To .Rows - 1
  1338.                     If .TextMatrix(Rowjsq, 0) <> "*" Then
  1339.                         Exit For
  1340.                     End If
  1341.                 Next Rowjsq
  1342.                 If Rowjsq <= .Rows - 1 Then
  1343.                     Changelock = True
  1344.                     .Select Rowjsq, .Col
  1345.                     Changelock = False
  1346.                 Else
  1347.                     Changelock = True
  1348.                     .Select .Rows - 1, .Col
  1349.                     Changelock = False
  1350.                 End If
  1351.             End If
  1352.             Call Xldqh
  1353.         End If
  1354.   End With
  1355.   
  1356. End Sub
  1358. Private Sub Xldqh()                                                      '显露当前行
  1359.   
  1360.     Dim Toprowte As Long
  1361.     With WglrGrid
  1362.         Toprowte = 0
  1363.         Do While .CellTop + .RowHeight(.Row) + Fzxwghs * Sjhgd > .Height And .TopRow <> Toprowte
  1364.             Toprowte = .TopRow
  1365.             .TopRow = .TopRow + 1
  1366.         Loop
  1367.         Toprowte = 0
  1368.         Do While .CellTop < .FixedRows * .RowHeight(0) And .TopRow <> Toprowte
  1369.             Toprowte = .TopRow
  1370.             If .TopRow > 1 Then
  1371.                 .TopRow = .TopRow - 1
  1372.             End If
  1373.         Loop
  1374.     End With
  1376. End Sub
  1378. Private Sub Xldql()                                                     '显露当前列
  1379.     
  1380.     Dim Leftcolte As Long
  1381.     With WglrGrid
  1382.         If .Col >= Qslz And .Col >= .FixedCols Then
  1383.             If .LeftCol > .Col Then
  1384.                 .LeftCol = .Col
  1385.             End If
  1386.             Leftcolte = 0
  1387.             Do While .CellLeft + .CellWidth > .Width And .LeftCol <> Leftcolte
  1388.                 Leftcolte = .LeftCol
  1389.                 .LeftCol = .LeftCol + 1
  1390.             Loop
  1391.         End If
  1392.     End With
  1394. End Sub
  1396. Private Function pdhwk(sjh As Long)                                     '判断网格行是否为空行(所有录入字段均为空*非录入字段除外)
  1397.     
  1398.     With WglrGrid
  1399.         For Coljsq = Qslz To .Cols - 1
  1400.             If Len(Trim(.TextMatrix(sjh, Coljsq))) <> 0 And GridBoolean(Coljsq, 1) Then
  1401.                 pdhwk = False
  1402.                 Exit Function
  1403.             End If
  1404.         Next Coljsq
  1405.         pdhwk = True
  1406.     End With
  1408. End Function
  1410. Private Sub Xyxhbz(sjh As Long)                                         '写行有效性标志,并判断是否增行
  1411.     
  1412.     With WglrGrid
  1413.         If .TextMatrix(sjh, 0) = "*" Then
  1414.             Exit Sub
  1415.         End If
  1416.         .TextMatrix(sjh, 0) = "*"
  1417.         If sjh >= .Rows - Fzxwghs - 1 Then
  1418.             .AddItem ""
  1419.             .RowHeight(.Rows - 1) = Sjhgd
  1420.         End If
  1421.     End With
  1423. End Sub
  1425. '*****************************以下为文本框录入处理程序(固定不变部分)*******************************'
  1427. Private Sub Wbklrwbcl(Index As Integer)    '文本框录入事后处理程序
  1429.     Dim int_temp As Integer
  1430.     Dim Str_Temp As String
  1431.     Dim int_Row  As Integer
  1432.     Dim rst_Temp As New ADODB.Recordset
  1433.     Dim str_sqlTemp As String
  1435.     '以下为依据实际情况自定义部分[
  1436.     TextChangeLock = True
  1437.         Select Case Index
  1438.             Case 3 '计划号
  1439.                 If Trim(LrText(3).Tag) <> "" Then
  1440.                     str_sqlTemp = "select * from Cg_V_PlanForPurRecipt where PurPlanMainID=" & S2N(LrText(Index).Tag)
  1441.                     Set rst_Temp = Cw_DataEnvi.DataConnect.Execute(str_sqlTemp)
  1442.                     If rst_Temp.RecordCount <> 0 Then
  1443.                         LrText(5).Tag = rst_Temp.Fields("SupplierCode").Value
  1444.                         LrText(5).Text = rst_Temp.Fields("SupplierName").Value
  1445.                         LrText(4).Tag = ""
  1446.                         LrText(4).Text = ""
  1447.                         LrText(2).Tag = ""
  1448.                         LrText(2).Text = ""
  1449.                         With WglrGrid
  1450.                             .Clear 1
  1451.                             For int_temp = .FixedRows To .Rows - 1
  1452.                                 If Trim(.TextMatrix(int_temp, 0)) <> "*" Then
  1453.                                     int_Row = int_temp
  1454.                                     Exit For
  1455.                                 End If
  1456.                             Next int_temp
  1457.                             rst_Temp.MoveFirst
  1458.                             For int_temp = int_Row To rst_Temp.RecordCount + int_Row - 1
  1459.                                 If int_temp >= .Rows Then
  1460.                                    .AddItem ""
  1461.                                    .RowHeight(int_temp) = Sjhgd
  1462.                                 End If
  1463.                                 .TextMatrix(int_temp, 0) = "*"
  1464.                                 .TextMatrix(int_temp, 2) = rst_Temp.Fields("Ispcgl")
  1465.                                 .TextMatrix(int_temp, Sydz("001", GridStr(), Szzls)) = rst_Temp.Fields("Mnumber") & ""
  1466.                                 .TextMatrix(int_temp, Sydz("002", GridStr(), Szzls)) = rst_Temp.Fields("Mname") & ""
  1467.                                 .TextMatrix(int_temp, Sydz("003", GridStr(), Szzls)) = rst_Temp.Fields("model") & ""
  1468.                                 .TextMatrix(int_temp, Sydz("004", GridStr(), Szzls)) = rst_Temp.Fields("PurUnitName") & ""
  1469.                                 rst_Temp.MoveNext
  1470.                             Next int_temp
  1471.                             If int_temp >= .Rows Then
  1472.                                    .AddItem ""
  1473.                                    .RowHeight(int_temp) = Sjhgd
  1474.                                    .AddItem ""
  1475.                                    .RowHeight(int_temp + 1) = Sjhgd
  1476.                                    .AddItem ""
  1477.                                    .RowHeight(int_temp + 2) = Sjhgd
  1478.                             End If
  1479.                         End With
  1480.                         Call Sub_AdjustGrid
  1481.                     End If
  1482.                     rst_Temp.Close
  1483.                     Set rst_Temp = Nothing
  1484.                 End If
  1485.             Case 4 '订单号
  1486.                 If Trim(LrText(4).Tag) <> "" Then
  1487.                     str_sqlTemp = "SELECT OrderFormMainID, OrderFormNum, PurPlanMainID, PurPlanNum, SupplierCode," & _
  1488.                                                  " DeptCode, PersonCode, SupplierName, DeptName, PersonName, MNumber, MName, " & _
  1489.                                                  " Model , PurUnitName, TransferWayCode, TransferWayName ,IsCheck,Ispcgl " & _
  1490.                                            " From Cg_V_OrderForm where " & _
  1491.                                 " OrderFormMainID = " & S2N(LrText(Index).Tag)
  1492.                     Set rst_Temp = Cw_DataEnvi.DataConnect.Execute(str_sqlTemp)
  1493.                     If rst_Temp.RecordCount <> 0 Then
  1494.                         LrText(3).Tag = IIf(IsNull(rst_Temp.Fields("PurPlanMainID").Value), "", rst_Temp.Fields("PurPlanMainID").Value)
  1495.                         LrText(3).Text = Trim("" & rst_Temp.Fields("PurPlanNum").Value)
  1496.                         LrText(5).Tag = Trim("" & rst_Temp.Fields("SupplierCode").Value)
  1497.                         LrText(5).Text = Trim("" & rst_Temp.Fields("SupplierName").Value)
  1498.                         LrText(6).Tag = Trim("" & rst_Temp.Fields("DeptCode").Value)
  1499.                         LrText(6).Text = Trim("" & rst_Temp.Fields("DeptName").Value)
  1500.                         LrText(7).Tag = Trim("" & rst_Temp.Fields("PersonCode").Value)
  1501.                         LrText(7).Text = Trim("" & rst_Temp.Fields("PersonName").Value)
  1502.                         LrText(10).Tag = Trim("" & rst_Temp.Fields("TransferWayCode").Value)
  1503.                         LrText(10).Text = Trim("" & rst_Temp.Fields("TransferWayName").Value)
  1504.                         LrText(2).Text = ""
  1505.                         LrText(2).Tag = ""
  1506.                         With WglrGrid
  1507.                             .Clear 1
  1508.                             For int_temp = .FixedRows To .Rows - 1
  1509.                                 If Trim(.TextMatrix(int_temp, 0)) <> "*" Then
  1510.                                     int_Row = int_temp
  1511.                                     Exit For
  1512.                                 End If
  1513.                             Next int_temp
  1514.                             rst_Temp.MoveFirst
  1515.                             For int_temp = int_Row To rst_Temp.RecordCount + int_Row - 1
  1516.                                 If int_temp >= .Rows Then
  1517.                                    .AddItem ""
  1518.                                    .RowHeight(int_temp) = Sjhgd
  1519.                                 End If
  1520.                                 .TextMatrix(int_temp, 0) = "*"
  1521.                                 .TextMatrix(int_temp, 2) = rst_Temp.Fields("Ispcgl")
  1522.                                 .TextMatrix(int_temp, Sydz("001", GridStr(), Szzls)) = Trim("" & rst_Temp.Fields("Mnumber"))
  1523.                                 .TextMatrix(int_temp, Sydz("002", GridStr(), Szzls)) = Trim("" & rst_Temp.Fields("Mname"))
  1524.                                 .TextMatrix(int_temp, Sydz("003", GridStr(), Szzls)) = Trim("" & rst_Temp.Fields("model"))
  1525.                                 .TextMatrix(int_temp, Sydz("004", GridStr(), Szzls)) = Trim("" & rst_Temp.Fields("PurUnitName"))
  1526.                                 rst_Temp.MoveNext
  1527.                             Next int_temp
  1528.                             
  1529.                         End With
  1530.                         Call Sub_AdjustGrid
  1531.                     End If
  1532.                     rst_Temp.Close
  1533.                     Set rst_Temp = Nothing
  1534.                 End If
  1535.             Case 2 '收料通知单
  1536.                 If Trim(LrText(2).Tag) <> "" Then
  1537.                     str_sqlTemp = "SELECT PurReciptMainID, PurPlanNum, PurPlanMainID, OrderFormNum, OrderFormMainID, " & _
  1538.                                       " MNumber, BatchNum, VehicleNum, WhName, MName, Model, PurUnitName, " & _
  1539.                                       " TranCompanyName, SupplierName, DeptName, DeptCode, PurTypeCode, " & _
  1540.                                       " SupplierCode, PersonCode, WhCode, TransferWayCode, InOutClassCode, " & _
  1541.                                       " TranCompanyCode, BillCode, PurReciptNum, PurReciptDate, ChalkitupMan, " & _
  1542.                                       " InOutClassName , TransferWayName, PersonName,Ispcgl " & _
  1543.                                 " FROM Cg_V_PurRecipt where " & _
  1544.                                 " PurReciptMainID = " & S2N(LrText(Index).Tag)
  1545.                     Set rst_Temp = Cw_DataEnvi.DataConnect.Execute(str_sqlTemp)
  1546.                     If rst_Temp.RecordCount <> 0 Then
  1547.                         LrText(3).Tag = IIf(IsNull(rst_Temp.Fields("PurPlanMainID").Value), "", rst_Temp.Fields("PurPlanMainID").Value)
  1548.                         LrText(3).Text = Trim("" & rst_Temp.Fields("PurPlanNum").Value)
  1549.                         
  1550.                         LrText(4).Tag = IIf(IsNull(rst_Temp.Fields("OrderFormMainID").Value), "", rst_Temp.Fields("OrderFormMainID").Value)
  1551.                         LrText(4).Text = Trim("" & rst_Temp.Fields("OrderFormNum").Value)
  1552.                         
  1553.                         LrText(5).Tag = rst_Temp.Fields("SupplierCode").Value
  1554.                         LrText(5).Text = rst_Temp.Fields("SupplierName").Value
  1555.                         LrText(6).Tag = Trim("" & rst_Temp.Fields("DeptCode").Value)
  1556.                         LrText(6).Text = Trim("" & rst_Temp.Fields("DeptName").Value)
  1557.                         LrText(7).Tag = Trim("" & rst_Temp.Fields("PersonCode").Value)
  1558.                         LrText(7).Text = Trim("" & rst_Temp.Fields("PersonName").Value)
  1559.                         
  1560.                         LrText(8).Tag = Trim("" & rst_Temp.Fields("WhCode").Value)
  1561.                         LrText(8).Text = Trim("" & rst_Temp.Fields("WhName").Value)
  1562.                         
  1563.                         LrText(10).Tag = Trim("" & rst_Temp.Fields("TransferWayCode").Value)
  1564.                         LrText(10).Text = Trim("" & rst_Temp.Fields("TransferWayName").Value)
  1565.                         
  1566.                         LrText(11).Tag = Trim("" & rst_Temp.Fields("TranCompanyCode").Value)
  1567.                         LrText(11).Text = Trim("" & rst_Temp.Fields("TranCompanyName").Value)
  1568.                         
  1569.                         With WglrGrid
  1570.                             .Clear 1
  1571.                             For int_temp = .FixedRows To .Rows - 1
  1572.                                 If Trim(.TextMatrix(int_temp, 0)) <> "*" Then
  1573.                                     int_Row = int_temp
  1574.                                     Exit For
  1575.                                 End If
  1576.                             Next int_temp
  1577.                             rst_Temp.MoveFirst
  1578.                             For int_temp = int_Row To rst_Temp.RecordCount + int_Row - 1
  1579.                                 If int_temp >= .Rows Then
  1580.                                    .AddItem ""
  1581.                                    .RowHeight(int_temp) = Sjhgd
  1582.                                 End If
  1583.                                 .TextMatrix(int_temp, 0) = "*"
  1584.                                 .TextMatrix(int_temp, 2) = rst_Temp.Fields("Ispcgl")
  1585.                                 .TextMatrix(int_temp, Sydz("001", GridStr(), Szzls)) = Trim("" & rst_Temp.Fields("Mnumber"))
  1586.                                 .TextMatrix(int_temp, Sydz("002", GridStr(), Szzls)) = Trim("" & rst_Temp.Fields("Mname"))
  1587.                                 .TextMatrix(int_temp, Sydz("003", GridStr(), Szzls)) = Trim("" & rst_Temp.Fields("model"))
  1588.                                 .TextMatrix(int_temp, Sydz("004", GridStr(), Szzls)) = Trim("" & rst_Temp.Fields("PurUnitName"))
  1589.                                 .TextMatrix(int_temp, Sydz("009", GridStr(), Szzls)) = Trim("" & rst_Temp.Fields("VehicleNum"))
  1590.                                 rst_Temp.MoveNext
  1591.                             Next int_temp
  1592.                             
  1593.                         End With
  1594.                         Call Sub_AdjustGrid
  1595.                     End If
  1596.                     rst_Temp.Close
  1597.                     Set rst_Temp = Nothing
  1598.                 End If
  1599.             
  1600.         End Select
  1601.     TextChangeLock = False
  1602.     ']以上为依据实际情况自定义部分
  1603.     '计算合计数据(Fixed)
  1604.     Dim jsqte As Long                              '临时计数器
  1605.     For jsqte = Qslz To WglrGrid.Cols - 1
  1606.         Call Sjhj(jsqte)
  1607.     Next jsqte
  1608.     
  1609. End Sub
  1611. Private Sub LrText_Change(Index As Integer)
  1613.     '屏蔽程序改变控制
  1614.     If TextChangeLock Then
  1615.         Exit Sub
  1616.     End If
  1617.    
  1618.     TextValiJudgeLock(Index) = False    '打开有效性判断锁
  1619.         
  1620.     '限制字段录入长度
  1621.           
  1622.     TextChangeLock = True  '加锁(防止执行Lrtext_Change)
  1623.     Call TextChangeLimit(LrText(Index), Textint(Index, 1))  '去掉无效字符
  1624.         Select Case Textint(Index, 1)
  1625.             Case 8, 11       '金额型
  1626.                 Call Sjgskz(LrText(Index), Xtjezws - Xtjexsws - 1, Xtjexsws)
  1627.             Case 9, 12       '数量型
  1628.                 Call Sjgskz(LrText(Index), Xtslzws - Xtslxsws - 1, Xtslxsws)
  1629.             Case 10          '单价型
  1630.                 Call Sjgskz(LrText(Index), Xtdjzws - Xtdjxsws - 1, Xtdjxsws)
  1631.             Case Else        '其他小数类型控制
  1632.                 If Textint(Index, 6) <> 0 Or Textint(Index, 7) <> 0 Then
  1633.                     Call Sjgskz(LrText(Index), Textint(Index, 6), Textint(Index, 7))
  1634.                 End If
  1635.         End Select
  1636.         
  1637.         TextChangeLock = False '解锁
  1638.      
  1639. End Sub
  1641. Private Sub LrText_GotFocus(Index As Integer)                                                 '文本框得到焦点,显示相应信息
  1642.     Call TextShow(Index)
  1643. End Sub
  1645. Private Sub LrText_KeyDown(Index As Integer, KeyCode As Integer, Shift As Integer)            '字段按F2键提供帮助
  1646.     
  1647.     Select Case KeyCode
  1648.         Case vbKeyF2
  1649.             Call Text_Help(Index)
  1650.     End Select
  1652. End Sub
  1654. Private Sub LrText_KeyPress(Index As Integer, KeyAscii As Integer)                            '文本框录入事中控制
  1655.     Call InputFieldLimit(LrText(Index), Textint(Index, 1), KeyAscii)
  1656. End Sub
  1658. Private Sub LrText_LostFocus(Index As Integer)                                                '文本框失去焦点进行有效性判断及相应处理
  1659.     
  1660.     If Textint(Index, 9) = 0 Or Textint(Index, 9) = 1 Then '事中判断
  1661.         Call TextYxxpd(Index)
  1662.     End If
  1664. End Sub
  1666. Private Sub Ydcommand1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single) '点击按钮
  1667.     Call Text_Help(Ydcommand1.Tag)
  1668. End Sub
  1670. Private Sub Text_Help(Index As Integer)                                                       '录入字段帮助
  1671.     
  1672.     If Not Ydcommand1.Visible Then
  1673.         Exit Sub
  1674.     End If
  1675.     TextValiLock = True
  1676.     Call Drbmhelp(Textint(Index, 2), Textstr(Index, 4), Trim(LrText(Index).Text))
  1677.     If Len(Xtfhcs) <> 0 Then
  1678.         If Textint(Index, 3) = 1 Then
  1679.             LrText(Index).Text = Xtfhcsfz
  1680.             LrText(Index).Tag = Xtfhcs
  1681.         Else
  1682.             LrText(Index).Text = Xtfhcs
  1683.             LrText(Index).Tag = Xtfhcsfz
  1684.         End If
  1685.     End If
  1686.     TextValiLock = False
  1687.     LrText(Index).SetFocus
  1688.     
  1689.     
  1690. End Sub
  1692. Private Sub TextShow(Index As Integer)        '文本框得到焦点,显示相应信息
  1694.     '如果文本框有帮助,则显示帮助按钮
  1695.     If Textboolean(Index, 1) Then
  1696.         Ydcommand1.Visible = True
  1697.         Ydcommand1.Move LrText(Index).Left + LrText(Index).Width, LrText(Index).Top
  1698.         Ydcommand1.Tag = Index
  1699.     Else
  1700.         Ydcommand1.Tag = ""
  1701.         Ydcommand1.Visible = False
  1702.     End If
  1703.     
  1704.     '[>>
  1705.     '可在此处定义其他处理动作
  1706.     '<<]
  1708. End Sub
  1710. Private Sub Wbkcsh()                          '录入文本框初始化
  1711. Dim Int_TabIndex As Integer         'Tab焦点计数器    '单据录入中文本框焦点由0开始
  1712.     LrText(0).TabIndex = 0
  1713.   
  1714.     '最大录入文本框索引值
  1715.     Max_Text_Index = Textvar(1)
  1716.   
  1717.     ReDim TextValiJudgeLock(Max_Text_Index)
  1718.     For jsqte = 0 To Max_Text_Index
  1719.         
  1720.         '判断此文本框录入索引号是否存在,如存在则对其进行初始化
  1721.         If Len(Trim(Textstr(jsqte, 1))) <> 0 Then
  1722.         
  1723.             '自动装入录入文本框和其解释标签
  1724.             If jsqte <> 0 Then
  1725.                 Load LrText(jsqte)
  1726.                 Load TsLabel(jsqte)
  1727.            
  1728.                 '判断录入文本框是否显示
  1729.                 If Textboolean(jsqte, 4) Then
  1730.                     LrText(jsqte).Visible = True
  1731.                     TsLabel(jsqte).Visible = True
  1732.                 End If
  1733.             
  1734.                 '设置文本框焦点顺序值
  1735.                 LrText(jsqte).TabIndex = Textint(jsqte, 14)
  1736.            
  1737.                 '判断文本框是否可编辑
  1738.                 If Textboolean(jsqte, 5) Then
  1739.                     LrText(jsqte).Enabled = True
  1740.                 Else
  1741.                     LrText(jsqte).Enabled = False
  1742.                 End If
  1743.             End If
  1744.            
  1745.            '初始化其内容
  1746.             TextChangeLock = True
  1747.             LrText(jsqte).Text = ""
  1748.             LrText(jsqte).Tag = ""
  1749.             LrText(jsqte).MaxLength = Textint(jsqte, 5)
  1750.             TextChangeLock = False
  1751.         
  1752.             '设置文本框位置及大小,并设置相应标签内容及其位置
  1753.             LrText(jsqte).Move Textint(jsqte, 13), Textint(jsqte, 12), Textint(jsqte, 11), Textint(jsqte, 10)
  1754.             TsLabel(jsqte).Caption = Textstr(jsqte, 7) & ":"
  1755.             TsLabel(jsqte).Move Textint(jsqte, 13) - TsLabel(jsqte).Width - 20, Textint(jsqte, 12) + (Textint(jsqte, 10) - TsLabel(jsqte).Height) / 2 - 30
  1756.             
  1757.         End If
  1758.      
  1759.         '将文本框有效性判断进行加锁,在文本框内容发生变化时将锁打开
  1760.         TextValiJudgeLock(jsqte) = True
  1761.       
  1762.     Next jsqte
  1763.  '设置文本框焦点转移顺序(前提文本焦点从0至Max_Text_Index)
  1764.     For Int_TabIndex = 0 To Max_Text_Index
  1765.         For jsqte = 0 To Max_Text_Index
  1766.             If Textint(jsqte, 14) = Int_TabIndex Then
  1767.                LrText(jsqte).TabIndex = Int_TabIndex
  1768.             End If
  1769.         Next jsqte
  1770.     Next Int_TabIndex
  1771. End Sub
  1773. Private Function TextYxxpd(Index As Integer) As Boolean           '文本框有效性判断
  1774.   
  1775.     Dim Sqlstr As String
  1776.     Dim Findrec As New ADODB.Recordset
  1777.   
  1778.     '按帮助不进行有效性判断
  1779.   
  1780.     If TextValiLock Then
  1781.         TextValiLock = False
  1782.         TextYxxpd = True
  1783.         Exit Function
  1784.     End If
  1785.   
  1786.     '文本框内容未曾改变不进行有效性判断
  1787.   
  1788.     If TextValiJudgeLock(Index) Then
  1789.         Ydcommand1.Visible = False
  1790.         TextYxxpd = True
  1791.         Exit Function
  1792.     End If
  1793.   
  1794.     '文本框内容为空认为有效,并清空其Tag值
  1795.   
  1796.     If Trim(LrText(Index)) = "" Then
  1797.         LrText(Index).Tag = ""
  1798.         Call Wbklrwbcl(Index)
  1799.         Ydcommand1.Visible = False
  1800.         TextValiJudgeLock(Index) = True
  1801.         TextYxxpd = True
  1802.         Exit Function
  1803.     End If
  1804.    
  1805.     '[>>
  1806.       
  1807.     '可在此加入不做有效性判断的理由(参照上面程序)
  1808.       
  1809.     '<<]
  1810.   
  1811.     Select Case Textint(Index, 4)
  1812.         Case 1      '编码型
  1813.             Sqlstr = Trim(Textstr(Index, 5))
  1814.             Sqlstr = Replace(Sqlstr, "@", "'" + Trim(LrText(Index).Text) + "'")
  1815.             '''''''''修必状态时做的判断
  1816.             If Lab_OperStatus.Caption = "3" Then
  1817.                 If Index = 4 Then '订单
  1818.                     Sqlstr = "SELECT OrderFormMainID, OrderFormNum, OrderFormDate, PurPlanNum, OldOrderNum, SupplierName, DeptName FROM Cg_V_OrderForm where (LTRIM(RTRIM(ISNULL(Checker,''))) <> '')  and ( OrderFormNum='" & Trim(LrText(Index).Text) & "')"
  1819.                 ElseIf Index = 3 Then '计划号
  1820.                     Sqlstr = "SELECT PurPlanMainID, kjYear, Period, PurPlanNum, PurPlanDate, PurPlanType,DeptName, SupplierName FROM Cg_V_PlanBill where SplitUniteFlag=0  and ltrim(rtrim(isnull(transmitter,'')))<>'' and (PurPlanNum='" & Trim(LrText(Index).Text) & "')"
  1821.                 End If
  1822.             End If
  1823.             ''''
  1824.             Set Findrec = Cw_DataEnvi.DataConnect.Execute(Sqlstr)
  1825.             If Findrec.EOF Then
  1826.                 Call Xtxxts(Trim(Textstr(Index, 6)), 0, 1)
  1827.                 LrText(Index).SetFocus
  1828.                 Exit Function
  1829.             Else
  1830.                 Select Case Textint(Index, 3)
  1831.                     Case 0
  1832.                         If Len(Trim(Textstr(Index, 2))) <> 0 Then
  1833.                             LrText(Index).Text = Trim(Findrec.Fields(Trim(Textstr(Index, 2))))
  1834.                         End If
  1835.                         If Len(Trim(Textstr(Index, 3) & "")) <> 0 Then
  1836.                             LrText(Index).Tag = Trim(Findrec.Fields(Trim(Textstr(Index, 3))))
  1837.                         End If
  1838.                     Case 1
  1839.                         If Len(Trim(Textstr(Index, 3) & "")) <> 0 Then
  1840.                             LrText(Index).Text = Trim(Findrec.Fields(Trim(Textstr(Index, 3))))
  1841.                         End If
  1842.                         If Len(Trim(Textstr(Index, 2))) <> 0 Then
  1843.                             LrText(Index).Tag = Trim(Findrec.Fields(Trim(Textstr(Index, 2))))
  1844.                         End If
  1845.                 End Select
  1846.             End If
  1847.         Case 2      '日期型
  1848.             If IsDate(LrText(Index).Text) Then
  1849.                 LrText(Index).Text = Format(LrText(Index).Text, "yyyy-mm-dd")
  1850.                 If S2N(Mid(LrText(Index), 1, 4)) < 1900 Then
  1851.                     LrText(Index).Text = "1900" + Mid(LrText(Index), 5, 6)
  1852.                 End If
  1853.             Else
  1854.                 Tsxx = "非法公历日期!(格式:" + Format(Date, "yyyy-mm-dd") + ")"
  1855.                 Call Xtxxts(Tsxx, 0, 1)
  1856.                 LrText(Index).SetFocus
  1857.                 Exit Function
  1858.             End If
  1859.         Case 3      '其他类型
  1860.     End Select
  1861.     
  1862.     '隐藏帮助按钮
  1863.     Ydcommand1.Visible = False
  1864.    
  1865.     '如果有效则加锁,用户不改变内容则不再进行有效性判断
  1866.     TextValiJudgeLock(Index) = True
  1868.     '调用文本框事后处理程序
  1869.     Call Wbklrwbcl(Index)
  1870.    
  1871.     '有效性判断通过则返回True
  1872.     TextYxxpd = True
  1873.     
  1874. End Function