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

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

企业管理

开发平台：

Visual Basic

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