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

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

企业管理

开发平台：

Visual Basic

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