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

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

企业管理

开发平台：

Visual Basic

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