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

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

企业管理

开发平台：

Visual Basic

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