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

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

企业管理

开发平台：

Visual Basic

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