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

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

企业管理

开发平台：

Visual Basic

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