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

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

企业管理

开发平台：

Visual Basic

ʰ：源码内容
  1.     
  2.     If Val(.TextMatrix(Lng_GridRow, 22)) <> 0 Then
  3.        Str_Memo = Str_Memo + "项目数量:" + Trim(.TextMatrix(Lng_GridRow, 22)) + Trim(.TextMatrix(Lng_GridRow, 23)) + Space(2)
  4.     End If
  5.     
  6.     If Len(Trim(.TextMatrix(Lng_GridRow, 24))) <> 0 Then
  7.        Str_Memo = Str_Memo + "经办人:" + Trim(.TextMatrix(Lng_GridRow, 24))
  8.     End If
  9.     
  10.     Lab_Memo(0).Caption = Str_Memo
  11.     Lab_Memo(0).Refresh
  12.     
  13.   End With
  15. End Sub
  16. Private Sub Sub_AddBill()                                                '新增一张单据
  17.    Dim RecTemp As New ADODB.Recordset     '临时使用动态集
  18.    Dim Jsqte As Long            '临时计数器
  19.    
  20.    '设置操作状态为新增
  21.    Lab_OperStatus.Caption = "2"
  22.    
  23.    '设置工具条状态
  24.    Call Sub_OperStatus("2")
  25.    
  26.    '计算新增单据单据号
  27.    Call Sub_JsVouchNo
  28.    
  29.    '显示制单人,清空记帐人,审核人
  30.    Lab_Book.Caption = ""
  31.    Lab_Checker.Caption = ""
  32.    Lab_Bill.Caption = Xtczy
  33.    
  34.    '重置网格
  35.    
  36.    With WglrGrid
  37.      .Rows = Pmbcsjhs + .FixedRows + Fzxwghs + 1
  38.      For Jsqte = .FixedRows To .Rows - 1
  39.          .RowHeight(Jsqte) = Sjhgd
  40.      Next Jsqte
  41.      
  42.      WglrGrid.Clear 1
  43.      
  44.      changelock = True
  45.        .Select .FixedRows, Qslz
  46.      changelock = False
  47.      
  48.    End With
  49.    
  50.    '计算合计数据(清零)
  51.     For Jsqte = Qslz To WglrGrid.Cols - 1
  52.         Call Sjhj(Jsqte)
  53.     Next Jsqte
  54.     
  55.    '凭证类别得到焦点
  56.    
  57.    LrText(0).SetFocus
  58.    
  59.    '有错凭证标识隐藏
  60.     
  61.    Lab_Error.Visible = False
  62.        
  63. End Sub
  64. Private Sub Sub_EditBill()                                                '修改一张单据
  65.    Dim RecTemp As New ADODB.Recordset     '临时使用动态集
  66.    
  67.    '判断当前凭证是否允许修改
  68.    If Not Fun_AllowEdit Then
  69.       Exit Sub
  70.    End If
  71.    
  72.    '设置操作状态为修改
  73.    Lab_OperStatus.Caption = "3"
  74.    
  75.    '设置工具条状态
  76.    Call Sub_OperStatus("30")
  77.    
  78.    '显示制单人
  79.     Lab_Bill.Caption = Xtczy
  80.    
  81. End Sub
  82. Private Sub Sub_DeleteBill()                                               '删除当前单据
  83.    Dim YAnswer As Integer
  84.    Dim Int_Year As Integer      '用户选择会计年度
  85.    Dim Int_Period As Integer    '用户选择会计期间
  86.   
  87.    '判断当前凭证是否允许删除
  88.    If Not Fun_AllowEdit Then
  89.       Exit Sub
  90.    End If
  91.    
  92.    Tsxx = "请确认是否删除当前凭证?"
  93.    Yhanswer = Xtxxts(Tsxx, 2, 2)
  94.    If Yhanswer = 1 Then
  95.       '1.删除凭证所有内容
  96.        Int_Year = Val(Mid(Combo_Kjqj.Text, 1, 4))
  97.        Int_Period = Val(Mid(Combo_Kjqj.Text, 6, 2))
  98.        Cw_DataEnvi.DataConnect.Execute ("Delete Cwzz_AccVouch Where Rectype=0 And Year=" & Int_Year & " and Period=" & Int_Period & " And VouchClassCode='" & Trim(LrText(0).Text) & "' And VouchNo=" & Val(LrText(3).Text))
  99.        Tsxx = "该凭证已被删除!"
  100.        Call Xtxxts(Tsxx, 0, 4)
  101.    Else
  102.       Exit Sub
  103.    End If
  104.      
  105.    Select Case Trim(Lab_Pzclzt.Caption)
  106.       Case "1"    '填制凭证
  107.         
  108.         Call Sub_AddBill
  109.         
  110.         '设置操作状态为浏览
  111.         Lab_OperStatus = "1"
  112.         Call Sub_OperStatus("10")
  113.    
  114.       Case "2"    '查询凭证
  115.    
  116.    End Select
  117. End Sub
  118. Private Sub Sub_AbandonBill()                                              '放弃对当前单据的操作
  120.  '先关闭录入载体
  121.   changelock = True
  122.   Valilock = True
  123.     Call Ycwbk
  124.   changelock = False
  125.   Valilock = False
  127.    Select Case Trim(Lab_OperStatus.Caption)
  128.       
  129.       Case "2"         '新增状态
  130.         
  131.         Call Sub_AddBill
  132.         
  133.         '设置操作状态为浏览
  134.         Lab_OperStatus = "1"
  135.         Call Sub_OperStatus("10")
  136.         
  137.       Case "3"         '修改状态
  138.       
  139.         '重新显示当前单据
  140.       
  141.         Call Sub_ShowBill
  142.         
  143.         '设置操作状态为浏览
  144.         Lab_OperStatus = "1"
  145.         Call Sub_OperStatus("11")
  147.    End Select
  148. End Sub
  149. Private Sub Sub_QueryBill()                                              '查询凭证
  150.    PZ_FrmPzcx.Show 1
  151.    If Xtfhcs = "1" Then
  152.       Call Sub_ShowBill
  153.       
  154.       '设置操作状态为浏览
  155.       Lab_OperStatus.Caption = "1"
  156.                 
  157.       '设置工具条状态
  158.       Call Sub_OperStatus("11")
  159.    End If
  160. End Sub
  161. Private Sub Combo_Kjqj_Click()                                           '会计期间发生变化则自动计算单据编号
  162.   Call Sub_JsVouchNo
  163. End Sub
  164. Private Sub Sub_JsVouchNo()                                              '自动计算新增单据编号
  165.   Dim RecTemp As New ADODB.Recordset     '临时使用动态集
  166.   
  167.   '单据为新增时才有效
  168.   If Lab_OperStatus <> "2" Then
  169.      Exit Sub
  170.   End If
  171.   
  172.   SQLSTR = "Select MAX(VouchNo) AS MVouchNo FROM  Cwzz_AccVouch Where Rectype=0 And Year=" & Mid(Combo_Kjqj.Text, 1, 4) & " AND Period=" & Mid(Combo_Kjqj.Text, 6, 2) & _
  173.            " AND VouchClassCode='" & Trim(LrText(0).Text) & "'"
  174.   Set RecTemp = Cw_DataEnvi.DataConnect.Execute(SQLSTR)
  175.   TextChangeLock = True
  176.      If Not IsNull(RecTemp.Fields("MVouchNo")) Then
  177.         LrText(3).Text = Mid(Trim(Str(10000 + RecTemp.Fields("MVouchNo") + 1)), 2, 4)
  178.      Else
  179.         LrText(3).Text = "0001"
  180.      End If
  181.   TextChangeLock = False
  182. End Sub
  183. Private Function Sub_SaveBill() As Boolean                   '保 存 单 据
  184.   Dim RecTemp As New ADODB.Recordset     '临时使用动态集
  185.   Dim Recfind As New ADODB.Recordset     '有效性判断动态集
  186.   Dim Rowjsq As Long           '网格行计数器
  187.   Dim Coljsq As Long           '网格列计数器
  188.   Dim Jsqte As Integer         '临时计数器
  189.   Dim Int_RowCount As Integer  '有效数据行计数器
  190.   Dim Bln_AssVali As Boolean   '辅助核算错误标识
  191.   Dim Lrywlz As Long           '录入有误列值
  192.   Dim Dbl_Jfhj As Double       '借方合计
  193.   Dim Dbl_Dfhj As Double       '贷方合计
  194.   Dim Int_Year As Integer      '用户选择会计年度
  195.   Dim Int_Period As Integer    '用户选择会计期间
  196.   Dim Int_VouchNo As Integer   '单据号
  197.   
  198.   For Jsqte = 0 To Max_Text_Index
  199.         If Textint(Jsqte, 8) = 1 Then     '字段不能为空
  200.            If Len(Trim(LrText(Jsqte).Text)) = 0 Then
  201.               Tsxx = Textstr(Jsqte, 7) & "不能为空!"
  202.                Call Xtxxts(Tsxx, 0, 1)
  203.                LrText(Jsqte).SetFocus
  204.                Sub_SaveBill = False
  205.                Exit Function
  206.            End If
  207.         Else
  208.           If Textint(Jsqte, 8) = 2 Then   '字段不能为零
  209.            If Val(Trim(LrText(Jsqte).Text)) = 0 Then
  210.                Tsxx = Textstr(Jsqte, 7) & "不能为零!"
  211.                Call Xtxxts(Tsxx, 0, 1)
  212.                LrText(Jsqte).SetFocus
  213.                Sub_SaveBill = False
  214.                Exit Function
  215.            End If
  216.           End If
  217.         End If
  218.     Next Jsqte
  219.     
  220.    '对需要进行事后判断的文本框录入内容进行有效性判断 (固定不变)
  221.   For Jsqte = 0 To Max_Text_Index
  222.     If Textint(Index, 9) = 0 Or Textint(Index, 9) = 2 Then
  223.       If Not TextYxxpd(Jsqte) Then
  224.          Exit Function
  225.       End If
  226.     End If
  227.   Next Jsqte
  228.   
  229.   '[判断用户所选会计期间是否有效(非结帐月份),且制单日期必须和所选会计期间一致
  230.   SQLSTR = "Select * FROM  XT_Kjrlb Where KjYear=" & Mid(Combo_Kjqj.Text, 1, 4) & " AND MM=" & Mid(Combo_Kjqj.Text, 6, 2)
  231.         
  232.   Set RecTemp = Cw_DataEnvi.DataConnect.Execute(SQLSTR)
  233.   
  234.   With RecTemp
  235.     If Not .EOF Then
  236.        If .Fields("Cwzzjzbz") Then
  237.           Tsxx = "所选会计期间已经结帐,不能再填制凭证!"
  238.           Call Xtxxts(Tsxx, 0, 1)
  239.           Combo_Kjqj.SetFocus
  240.           Exit Function
  241.        End If
  242.        
  243.        If Not (LrText(1).Text >= .Fields("Qsrq") And LrText(1).Text <= .Fields("Zzrq")) Then
  244.           Tsxx = "制单日期应在所选会计期间范围内!"
  245.           Call Xtxxts(Tsxx, 0, 1)
  246.           LrText(1).SetFocus
  247.           Exit Function
  248.        End If
  249.     End If
  250.   End With
  251.   
  252.   '下面将对所有有效数据行进行有效性判断
  253.   
  254.   Int_RowCount = 0
  255.   
  256.   Dbl_Jfhj = 0
  257.   
  258.   Dbl_Dfhj = 0
  259.   
  260.   With WglrGrid
  261.      
  262.      For Rowjsq = .FixedRows To .Rows
  263.      
  264.          '带*号者为有效数据行
  265.          
  266.          If .TextMatrix(Rowjsq, 0) <> "*" Then
  267.             Exit For
  268.          Else
  269.             Int_RowCount = Int_RowCount + 1
  270.          End If
  271.          
  272.          '1.首先进行为空或为零判断(固定不变)
  273.            For Coljsq = Qslz To .Cols - 1
  274.                If (GridInt(Coljsq, 5) = 1 And Len(Trim(.TextMatrix(Rowjsq, Coljsq))) = 0) Or (GridInt(Coljsq, 5) = 2 And Val(Trim(.TextMatrix(Rowjsq, Coljsq))) = 0) Then
  275.                   Tsxx = GridStr(Coljsq, 2)
  276.                   Lrywlz = Coljsq
  277.                   GoTo Lrcwcl
  278.                   Exit For
  279.                End If
  280.            Next Coljsq
  281.            
  282.          '2.[自定义判断(补丁)
  283.             If Val(Trim(.TextMatrix(Rowjsq, Sydz("004", GridStr(), Szzls)))) = 0 And Val(Trim(.TextMatrix(Rowjsq, Sydz("005", GridStr(), Szzls)))) = 0 Then
  284.                Tsxx = "借方和贷方金额不能同时为零!"
  285.                Lrywlz = Sydz("004", GridStr(), Szzls)
  286.                GoTo Lrcwcl
  287.             End If
  288.             
  289.             If Val(Trim(.TextMatrix(Rowjsq, Sydz("004", GridStr(), Szzls)))) <> 0 And Val(Trim(.TextMatrix(Rowjsq, Sydz("005", GridStr(), Szzls)))) <> 0 Then
  290.                Tsxx = "借方和贷方金额不能同时不为零!"
  291.                Lrywlz = Sydz("004", GridStr(), Szzls)
  292.                GoTo Lrcwcl
  293.             End If
  294.             
  295.             '判断辅助核算项目是否填写并是否有效
  296.                         
  297.             SQLSTR = "Select * FROM Cwzz_AccCode Where Ccode='" & Trim(.TextMatrix(Rowjsq, Sydz("002", GridStr(), Szzls))) & "'"
  298.       
  299.             Set RecTemp = Cw_DataEnvi.DataConnect.Execute(SQLSTR)
  300.                With RecTemp
  301.                  If .EOF Then
  302.                      Tsxx = "此科目不存在!"
  303.                      GoTo Lrcwcl
  304.                  End If
  305.                  If Not .Fields("EndFlag") Then
  306.                     Tsxx = "此科目非末级科目!"
  307.                     GoTo Lrcwcl
  308.                  End If
  309.                  If .Fields("StopUse") Then
  310.                     Tsxx = "此科目已停用"
  311.                     GoTo Lrcwcl
  312.                  End If
  313.                  
  314.                 '对于银行科目,如结算方式不为空则结算方式必须有效
  315.                 
  316.                  If Trim(RecTemp.Fields("Cproperty")) = "银行" And Len(Trim(WglrGrid.TextMatrix(Rowjsq, 1))) <> 0 Then
  317.                       Set Recfind = Cw_DataEnvi.DataConnect.Execute("Select SSCode FROM Cwzz_Settlement Where SSCode='" & Trim(WglrGrid.TextMatrix(Rowjsq, 1)) & "'")
  318.                       If Recfind.EOF Then
  319.                          Tsxx = "此结算方式不存在!"
  320.                          Lrywlz = Sydz("002", GridStr(), Szzls)
  321.                          Bln_AssVali = True
  322.                          GoTo Lrcwcl
  323.                       End If
  324.                  End If
  325.                  
  326.                 '如有数量核算且用户选择数量不能为零则数量项不能为零
  327.                  
  328.                  If RecTemp.Fields("QuantityFlag") And Chk_Quantity.Value = 1 And Val(WglrGrid.TextMatrix(Rowjsq, 5)) = 0 Then
  329.                     Tsxx = "此科目需要数量核算,数量项不能为零"
  330.                     Lrywlz = Sydz("002", GridStr(), Szzls)
  331.                     Bln_AssVali = True
  332.                     GoTo Lrcwcl
  333.                  End If
  334.                  
  335.                  
  336.                 '部门核算则部门不能为空且有效
  337.                 If RecTemp.Fields("DeptFlag") And Len(Trim(WglrGrid.TextMatrix(Rowjsq, 12))) = 0 Then
  338.                    Tsxx = "此科目需要部门核算,部门项不能为空"
  339.                    Lrywlz = Sydz("002", GridStr(), Szzls)
  340.                    Bln_AssVali = True
  341.                    GoTo Lrcwcl
  342.                 Else
  343.                    If RecTemp.Fields("DeptFlag") And Len(Trim(WglrGrid.TextMatrix(Rowjsq, 12))) <> 0 Then
  344.                       Set Recfind = Cw_DataEnvi.DataConnect.Execute("Select DeptCode FROM Gy_Department Where DeptCode='" & Trim(WglrGrid.TextMatrix(Rowjsq, 12)) & "'")
  345.                       If Recfind.EOF Then
  346.                          Tsxx = "此部门不存在!"
  347.                          Lrywlz = Sydz("002", GridStr(), Szzls)
  348.                          Bln_AssVali = True
  349.                          GoTo Lrcwcl
  350.                       End If
  351.                     End If
  352.                 End If
  353.                 
  354.                 '往来单位核算则往来单位不能为空
  355.                 If RecTemp.Fields("CusFlag") And Len(Trim(WglrGrid.TextMatrix(Rowjsq, 14))) = 0 Then
  356.                    Tsxx = "此科目需要往来单位核算,往来单位项不能为空"
  357.                    Lrywlz = Sydz("002", GridStr(), Szzls)
  358.                    Bln_AssVali = True
  359.                    GoTo Lrcwcl
  360.                 Else
  361.                    If RecTemp.Fields("CusFlag") And Len(Trim(WglrGrid.TextMatrix(Rowjsq, 14))) <> 0 Then
  362.                       Set Recfind = Cw_DataEnvi.DataConnect.Execute("Select CusCode FROM Gy_Customer Where CusCode='" & Trim(WglrGrid.TextMatrix(Rowjsq, 14)) & "'")
  363.                       If Recfind.EOF Then
  364.                          Tsxx = "此往来单位不存在!"
  365.                          Lrywlz = Sydz("002", GridStr(), Szzls)
  366.                          Bln_AssVali = True
  367.                          GoTo Lrcwcl
  368.                        End If
  369.                     End If
  370.                 End If
  371.                 
  372.                 '个人往来核算则个人项不能为空
  373.                 If RecTemp.Fields("PersonFlag") And Len(Trim(WglrGrid.TextMatrix(Rowjsq, 16))) = 0 Then
  374.                    Tsxx = "此科目需要个人往来核算,个人项不能为空"
  375.                    Lrywlz = Sydz("002", GridStr(), Szzls)
  376.                    Bln_AssVali = True
  377.                    GoTo Lrcwcl
  378.                 Else
  379.                    If RecTemp.Fields("PersonFlag") And Len(Trim(WglrGrid.TextMatrix(Rowjsq, 16))) <> 0 Then
  380.                       Set Recfind = Cw_DataEnvi.DataConnect.Execute("Select PersonCode FROM Gy_Person Where PersonCode='" & Trim(WglrGrid.TextMatrix(Rowjsq, 16)) & "'")
  381.                       If Recfind.EOF Then
  382.                          Tsxx = "此个人不存在!"
  383.                          Lrywlz = Sydz("002", GridStr(), Szzls)
  384.                          Bln_AssVali = True
  385.                          GoTo Lrcwcl
  386.                       End If
  387.                     End If
  388.                 End If
  389.                 
  390.                 '项目核算则项目不能为空
  391.                 If RecTemp.Fields("ItemFlag") And Len(Trim(WglrGrid.TextMatrix(Rowjsq, 20))) = 0 Then
  392.                    Tsxx = "此科目需要项目核算,核算项目不能为空"
  393.                    Lrywlz = Sydz("002", GridStr(), Szzls)
  394.                    Bln_AssVali = True
  395.                    GoTo Lrcwcl
  396.                 Else
  397.                    If RecTemp.Fields("ItemFlag") And Len(Trim(WglrGrid.TextMatrix(Rowjsq, 20))) <> 0 Then
  398.                       Set Recfind = Cw_DataEnvi.DataConnect.Execute("Select ItemCode,QuantityFlag FROM Cwzz_Item Where ItemClassCode='" & Trim(WglrGrid.TextMatrix(Rowjsq, 18)) & "' And ItemCode='" & Trim(WglrGrid.TextMatrix(Rowjsq, 20)) & "'")
  399.                       If Recfind.EOF Then
  400.                          Tsxx = "此核算项目不存在!"
  401.                          Lrywlz = Sydz("002", GridStr(), Szzls)
  402.                          Bln_AssVali = True
  403.                          GoTo Lrcwcl
  404.                       Else
  405.                          If Recfind.Fields("QuantityFlag") And Val(WglrGrid.TextMatrix(Rowjsq, 22)) = 0 Then
  406.                             Tsxx = "此项目需数量核算,则项目数量不能为零!"
  407.                             Lrywlz = Sydz("002", GridStr(), Szzls)
  408.                             Bln_AssVali = True
  409.                             GoTo Lrcwcl
  410.                           End If
  411.                       End If
  412.                     End If
  413.                 End If
  414.              End With
  415.              
  416.           '计算借贷方合计数据
  417.            
  418.            Dbl_Jfhj = Dbl_Jfhj + Val(WglrGrid.TextMatrix(Rowjsq, Sydz("004", GridStr(), Szzls)))
  419.              
  420.            Dbl_Dfhj = Dbl_Dfhj + Val(WglrGrid.TextMatrix(Rowjsq, Sydz("005", GridStr(), Szzls)))
  421.              
  422.      Next Rowjsq
  423.      
  424.      '会计分录行数不能为零
  425.      
  426.      If Int_RowCount = 0 Then
  427.         Tsxx = "凭证会计分录行数为零,不能存盘!"
  428.         Call Xtxxts(Tsxx, 0, 1)
  429.         Exit Function
  430.      End If
  431.      
  432.      '凭证借贷双方合计必须平衡
  433.      
  434.      If Dbl_Jfhj <> Dbl_Dfhj Then
  435.         Tsxx = "凭证借贷不平衡!"
  436.         Call Xtxxts(Tsxx, 0, 1)
  437.         Exit Function
  438.      End If
  439.      
  440.    End With  '网格
  441.    
  442.    '如果以上有效性检查均顺利通过,则执行存盘动作
  443.    
  444.     Int_Year = Val(Mid(Combo_Kjqj.Text, 1, 4))
  445.     
  446.     Int_Period = Val(Mid(Combo_Kjqj.Text, 6, 2))
  447.     
  448.     On Error GoTo Swcwcl
  449.     
  450.     Cw_DataEnvi.DataConnect.BeginTrans
  451.     
  452.     If Trim(Lab_OperStatus) = "2" Then
  453.     
  454.         '新增凭证
  455.         
  456.         '1.判断凭证号是否重复,如重复则取最大值+1为当前凭证号,否则已当前凭证号存盘
  457.         
  458.          SQLSTR = "Select Top 1 I_id From Cwzz_AccVouch Where Rectype=0 And Year=" & Int_Year & " and Period=" & Int_Period & " And VouchClassCode='" & Trim(LrText(0).Text) & "' And VouchNo=" & Val(LrText(3).Text)
  459.          Set Rec_AccVouch = Cw_DataEnvi.DataConnect.Execute(SQLSTR)
  460.          
  461.          If Not Rec_AccVouch.EOF Then
  462.             Call Sub_JsVouchNo
  463.          End If
  464.          
  465.     Else
  466.        
  467.         '修改凭证
  468.        
  469.         '1.删除原凭证所有内容
  470.         
  471.         Cw_DataEnvi.DataConnect.Execute ("Delete Cwzz_AccVouch Where Rectype=0 And Year=" & Int_Year & " and Period=" & Int_Period & " And VouchClassCode='" & Trim(LrText(0).Text) & "' And VouchNo=" & Val(LrText(3).Text))
  472.          
  473.     End If
  474.          
  475.          
  476.          Int_VouchNo = Val(LrText(3).Text)  '凭证号
  477.          
  478.          If Rec_AccVouch.State = 1 Then Rec_AccVouch.Close
  479.          
  480.          Rec_AccVouch.Open "Select * From Cwzz_AccVouch Where 1=2", Cw_DataEnvi.DataConnect, adOpenDynamic, adLockOptimistic
  481.          
  482.          For Rowjsq = WglrGrid.FixedRows To WglrGrid.Rows
  483.      
  484.              If WglrGrid.TextMatrix(Rowjsq, 0) <> "*" Then
  485.                 Exit For
  486.              End If
  487.              
  488.              With Rec_AccVouch
  489.                .AddNew
  490.                .Fields("RecType") = 0                                                                       '记录类型
  491.                .Fields("Year") = Int_Year                                                                   '会计年度
  492.                .Fields("Period") = Int_Period                                                               '会计期间
  493.                .Fields("Ddate") = CDate(LrText(1).Text)                                                     '制单日期
  494.                .Fields("VouchClassCode") = Trim(LrText(0).Text)                                             '凭证类别
  495.                .Fields("VouchNo") = Int_VouchNo                                                             '凭证号
  496.                .Fields("Doc") = Val(LrText(2).Text)                                                         '附单据数
  497.                .Fields("Bill") = Trim(Lab_Bill.Caption)                                                     '制单人
  498.                .Fields("Digest") = Trim(WglrGrid.TextMatrix(Rowjsq, Sydz("001", GridStr(), Szzls)))         '摘要
  499.                .Fields("Ccode") = Trim(WglrGrid.TextMatrix(Rowjsq, Sydz("002", GridStr(), Szzls)))          '会计科目
  500.                .Fields("Jfje") = Val(WglrGrid.TextMatrix(Rowjsq, Sydz("004", GridStr(), Szzls)))            '借方金额
  501.                .Fields("Dfje") = Val(WglrGrid.TextMatrix(Rowjsq, Sydz("005", GridStr(), Szzls)))            '贷方金额
  502.                If Val(WglrGrid.TextMatrix(Rowjsq, Sydz("004", GridStr(), Szzls))) <> 0 Then
  503.                   .Fields("Jfsl") = Val(WglrGrid.TextMatrix(Rowjsq, 5))                                     '借方数量
  504.                   Else
  505.                   .Fields("Dfsl") = Val(WglrGrid.TextMatrix(Rowjsq, 5))                                     '贷方数量
  506.                End If
  507.                If Len(Trim(WglrGrid.TextMatrix(Rowjsq, 8))) <> 0 Then
  508.                   .Fields("ForeignCurrCode") = Trim(WglrGrid.TextMatrix(Rowjsq, 8))                         '外币编码
  509.                   .Fields("AccRate") = Val(WglrGrid.TextMatrix(Rowjsq, 11))                                 '记帐汇率
  510.                   If Val(WglrGrid.TextMatrix(Rowjsq, Sydz("004", GridStr(), Szzls))) <> 0 Then
  511.                      .Fields("Wbjfje") = Val(WglrGrid.TextMatrix(Rowjsq, 10))                               '外币借方金额
  512.                   Else
  513.                      .Fields("Wbdfje") = Val(WglrGrid.TextMatrix(Rowjsq, 10))                               '外币贷方金额
  514.                   End If
  515.                End If
  516.                .Fields("CheckFlag") = 0                                                                     '审核标志置"0"
  517.                .Fields("BookFlag") = 0                                                                      '记帐标志置"0"
  518.                
  519.                If Len(Trim(WglrGrid.TextMatrix(Rowjsq, 4))) <> 0 Then
  520.                   .Fields("BillDate") = CDate(Trim(WglrGrid.TextMatrix(Rowjsq, 4)))                         '发生日期(银行)
  521.                End If
  522.                If Len(Trim(WglrGrid.TextMatrix(Rowjsq, 1))) <> 0 Then
  523.                   .Fields("SScode") = Trim(WglrGrid.TextMatrix(Rowjsq, 1))                                  '结算方式(银行)
  524.                End If
  525.                If Len(Trim(WglrGrid.TextMatrix(Rowjsq, 3))) <> 0 Then
  526.                   .Fields("BillNo") = Trim(WglrGrid.TextMatrix(Rowjsq, 3))                                  '票号(银行)
  527.                End If
  528.                
  529.                .Fields("BCheckFlag") = 0                                                                    '银行核对标志置0
  530.                
  531.                .Fields("BDelete") = 0                                                                       '银行帐核销标志置0
  532.                
  533.                If Len(Trim(WglrGrid.TextMatrix(Rowjsq, 16))) <> 0 Then
  534.                   .Fields("PersonCode") = Trim(WglrGrid.TextMatrix(Rowjsq, 16))                             '职员编码
  535.                End If
  536.                
  537.                If Len(Trim(WglrGrid.TextMatrix(Rowjsq, 12))) <> 0 Then
  538.                   .Fields("DeptCode") = Trim(WglrGrid.TextMatrix(Rowjsq, 12))                               '部门编码
  539.                End If
  540.                
  541.                If Len(Trim(WglrGrid.TextMatrix(Rowjsq, 14))) <> 0 Then
  542.                   .Fields("CusCode") = Trim(WglrGrid.TextMatrix(Rowjsq, 14))                                '往来单位编码
  543.                End If
  544.                
  545.                If Len(Trim(WglrGrid.TextMatrix(Rowjsq, 18))) <> 0 Then
  546.                   .Fields("ItemClassCode") = Trim(WglrGrid.TextMatrix(Rowjsq, 18))                          '项目大类编码
  547.                End If
  548.                
  549.                If Len(Trim(WglrGrid.TextMatrix(Rowjsq, 20))) <> 0 Then
  550.                   .Fields("ItemCode") = Trim(WglrGrid.TextMatrix(Rowjsq, 20))                               '项目编码
  551.                   If Val(WglrGrid.TextMatrix(Rowjsq, Sydz("004", GridStr(), Szzls))) <> 0 Then
  552.                      .Fields("ItemJfsl") = Val(WglrGrid.TextMatrix(Rowjsq, 22))                             '项目借方数量
  553.                   Else
  554.                      .Fields("ItemDfsl") = Val(WglrGrid.TextMatrix(Rowjsq, 22))                             '项目贷方数量
  555.                   End If
  556.                End If
  557.                
  558.                If Len(Trim(WglrGrid.TextMatrix(Rowjsq, 24))) <> 0 Then
  559.                   .Fields("TranPerson") = Trim(WglrGrid.TextMatrix(Rowjsq, 24))                             '经办人
  560.                End If
  562.            .Update
  563.             
  564.         End With
  565.     
  566.       Next Rowjsq
  567.     
  568.  
  569.   Cw_DataEnvi.DataConnect.CommitTrans
  571.   Sub_SaveBill = True
  572.   Tsxx = "凭证存盘完毕! 凭证号:" & Trim(LrText(0).Text) & "--" & Trim(LrText(3).Text)
  573.   Call Xtxxts(Tsxx, 0, 4)
  574.   
  575.   '标识单据发生改动
  576.   Bln_BillChange = True
  577.   
  578.   '设置操作状态为浏览
  579.    Lab_OperStatus = "1"
  580.    
  581.    Call Sub_OperStatus("11")
  582.   
  583.   Exit Function
  584.   
  585. Swcwcl:
  586.      Cw_DataEnvi.DataConnect.RollbackTrans
  587.      Tsxx = "存盘过程中出现未知错误,程序自动恢复保存前状态!"
  588.      Call Xtxxts(Tsxx, 0, 1)
  589.      Exit Function
  591. Lrcwcl:        '录入错误处理
  592.   With WglrGrid
  593.       Call Xtxxts("(第 " + Trim(Str(Int_RowCount)) + " 条会计分录)-" + Tsxx, 0, 1)
  594.       changelock = True
  595.       .Select Rowjsq, Lrywlz
  596.        WglrGrid.SetFocus
  597.       changelock = False
  598.       Exit Function
  599.   End With
  601. End Function
  602. Private Sub Chk_DeleteMess_Click()                   '删行是否提示(点击)
  603.    If Chk_DeleteMess.Value = 1 Then
  604.       Shsfts = True
  605.    Else
  606.       Shsfts = False
  607.    End If
  608. End Sub
  609. Private Sub Sub_Option()                             '调用填制凭证选项
  610.    With PZ_FrmOption
  611.    
  612.    '删行是否提示
  613.     .Chk_DeleteMess.Value = Me.Chk_DeleteMess.Value
  614.         
  615.      '科目数量核算数量项是否可以为零
  616.     .Chk_Quantity.Value = Me.Chk_Quantity.Value
  617.     
  618.     '打印凭证是否输出科目编码
  619.     .Chk_CodeOutput.Value = Me.Chk_CodeOutput.Value
  620.     
  621.     '审核凭证时是否自动跳到下张
  622.     .Chk_CheckNext.Value = Me.Chk_CheckNext.Value
  623.     
  624.     .Show 1
  625.     
  626.    End With
  628. End Sub
  630. '审核,弃审,标错,全审,全弃
  631. Private Sub Sub_CheckBill()             '审 核
  632.    Dim Int_Year As Integer      '用户选择会计年度
  633.    Dim Int_Period As Integer    '用户选择会计期间
  634.    
  635.    '已审核凭证不需要再次审核
  636.    If Trim(Lab_Checker.Caption) <> "" Then
  637.         Tsxx = "已审核凭证不需要再次审核!"
  638.         Call Xtxxts(Tsxx, 0, 4)
  639.         Exit Sub
  640.    End If
  641.    
  642.    '标错凭证不能审核通过
  643.    If Lab_Error.Visible Then
  644.         Tsxx = "标错凭证不能审核通过!"
  645.         Call Xtxxts(Tsxx, 0, 4)
  646.         Exit Sub
  647.    End If
  648.    
  649.    Int_Year = Val(Mid(Combo_Kjqj.Text, 1, 4))
  650.    Int_Period = Val(Mid(Combo_Kjqj.Text, 6, 2))
  651.    
  652.    '写入系统操作员
  653.    Lab_Checker.Caption = Xtczy
  654.    
  655.    '将凭证写入审核标识
  656.   Cw_DataEnvi.DataConnect.Execute ("Update Cwzz_AccVouch Set CheckFlag=1,Checker='" & Xtczy & "' Where Rectype=0 And Year=" & Int_Year & " and Period=" & Int_Period & " And VouchClassCode='" & Trim(LrText(0).Text) & "' And VouchNo=" & Val(LrText(3).Text))
  657.   
  658.   '自动调入下一张凭证
  659.   If Chk_CheckNext.Value = 1 Then
  660.      Call Sub_next
  661.   End If
  662.   
  663.   '标识单据发生变化
  664.   Bln_BillChange = True
  666. End Sub
  667. Private Sub Sub_AbandonCheck()          '弃 审
  668.    Dim Int_Year As Integer      '用户选择会计年度
  669.    Dim Int_Period As Integer    '用户选择会计期间
  670.    
  671.    If Trim(Lab_Book.Caption) <> "" Then
  672.         Tsxx = "已记帐凭证不能弃审!"
  673.         Call Xtxxts(Tsxx, 0, 4)
  674.         Exit Sub
  675.    End If
  676.    
  677.    If Trim(Lab_Checker.Caption) = "" Then
  678.         Tsxx = "未审核凭证不需要弃审!"
  679.         Call Xtxxts(Tsxx, 0, 4)
  680.         Exit Sub
  681.    End If
  682.    
  683.    Int_Year = Val(Mid(Combo_Kjqj.Text, 1, 4))
  684.    Int_Period = Val(Mid(Combo_Kjqj.Text, 6, 2))
  685.    
  686.    '写入系统操作员
  687.    Lab_Checker.Caption = ""
  688.    
  689.    '将凭证去掉审核标识
  690.   Cw_DataEnvi.DataConnect.Execute ("Update Cwzz_AccVouch Set CheckFlag=0,Checker='' Where Rectype=0 And Year=" & Int_Year & " and Period=" & Int_Period & " And VouchClassCode='" & Trim(LrText(0).Text) & "' And VouchNo=" & Val(LrText(3).Text))
  691.   
  692.   '自动调入下一张凭证
  693.   If Chk_CheckNext.Value = 1 Then
  694.      Call Sub_next
  695.   End If
  696.   
  697.   '标识单据发生变化
  698.   Bln_BillChange = True
  699.   
  700. End Sub
  701. Private Sub Sub_ErrorBill()             '标 错(如果凭证有错则去掉错误标识,如无错则写入错误标识)
  702.    Dim Int_Year As Integer      '用户选择会计年度
  703.    Dim Int_Period As Integer    '用户选择会计期间
  704.    
  705.    Int_Year = Val(Mid(Combo_Kjqj.Text, 1, 4))
  706.    Int_Period = Val(Mid(Combo_Kjqj.Text, 6, 2))
  707.    
  708.    If Lab_Error.Visible Then
  709.       
  710.         '去掉凭证有错标识
  711.         Lab_Error.Visible = False
  712.         
  713.         '将凭证去掉错误标识
  714.         Cw_DataEnvi.DataConnect.Execute ("Update Cwzz_AccVouch Set ErrorFlag=0 Where Rectype=0 And Year=" & Int_Year & " and Period=" & Int_Period & " And VouchClassCode='" & Trim(LrText(0).Text) & "' And VouchNo=" & Val(LrText(3).Text))
  715.    Else
  716.    
  717.      If Trim(Lab_Checker.Caption) <> "" Then
  718.         Tsxx = "已审核凭证不能标错!"
  719.         Call Xtxxts(Tsxx, 0, 4)
  720.         Exit Sub
  721.      End If
  722.      
  723.      '显示凭证有错标识
  724.      Lab_Error.Visible = True
  725.      
  726.      '将凭证写入错误标识
  727.      Cw_DataEnvi.DataConnect.Execute ("Update Cwzz_AccVouch Set ErrorFlag=1 Where Rectype=0 And Year=" & Int_Year & " and Period=" & Int_Period & " And VouchClassCode='" & Trim(LrText(0).Text) & "' And VouchNo=" & Val(LrText(3).Text))
  728.      
  729.    End If
  730.    
  731.    '标识单据发生变化
  732.   Bln_BillChange = True
  733.    
  734. End Sub
  735. Private Sub Sub_CheckAllBill()                       '全部审核
  736.    Dim Yhanswer As Integer
  737.    
  738.    Tsxx = "请确认是否将所有查询凭证中" + Chr(10) + Chr(10) + "未复核凭证全部复核(标错凭证除外)?"
  739.    Yhanswer = Xtxxts(Tsxx, 2, 2)
  740.    If Yhanswer = 2 Then
  741.       Exit Sub
  742.    End If
  743.    
  744.    If Not Lab_Error.Visible Then
  745.       '写入系统操作员
  746.       Lab_Checker.Caption = Xtczy
  747.    End If
  748.    
  749.   With PZ_FrmPzcxjg
  750.    
  751.    For Jsqte = .CxbbGrid.FixedRows To .CxbbGrid.Rows - 1
  752.   
  753.        If .CxbbGrid.Cell(flexcpBackColor, Jsqte) = .Lab_Color(0).BackColor Then
  754.         
  755.           '将凭证写入审核标识
  756.           Cw_DataEnvi.DataConnect.Execute ("Update Cwzz_AccVouch Set CheckFlag=1,Checker='" & Xtczy & "' Where Rectype=0 And ErrorFlag=0 And CheckFlag=0 and Year=" & Val(.CxbbGrid.TextMatrix(Jsqte, 0)) & " and Period=" & Val(.CxbbGrid.TextMatrix(Jsqte, 1)) & " And VouchClassCode='" & Trim(.CxbbGrid.TextMatrix(Jsqte, 2)) & "' And VouchNo=" & Val(.CxbbGrid.TextMatrix(Jsqte, 3)))
  757.           
  758.        End If
  759.    Next Jsqte
  760.    
  761.   End With
  762.   
  763.   Tsxx = "全部审核完毕!"
  764.   Call Xtxxts(Tsxx, 0, 4)
  765.   
  766.   '标识单据发生变化
  767.   Bln_BillChange = True
  769. End Sub
  771. Private Sub Sub_AbandonAllCheck()                       '全部弃审
  772.    Dim Yhanswer As Integer
  773.    
  774.    Tsxx = "请确认是否将所有查询凭证中" + Chr(10) + Chr(10) + "已复核凭证全部弃审(记帐凭证除外)?"
  775.    Yhanswer = Xtxxts(Tsxx, 2, 2)
  776.    If Yhanswer = 2 Then
  777.       Exit Sub
  778.    End If
  779.   
  780.   Lab_Checker.Caption = ""
  781.    
  782.   With PZ_FrmPzcxjg
  783.    
  784.    For Jsqte = .CxbbGrid.FixedRows To .CxbbGrid.Rows - 1
  785.   
  786.        If .CxbbGrid.Cell(flexcpBackColor, Jsqte) = .Lab_Color(0).BackColor Then
  787.         
  788.           '将凭证写入审核标识
  789.           Cw_DataEnvi.DataConnect.Execute ("Update Cwzz_AccVouch Set CheckFlag=0,Checker='' Where Rectype=0 And BookFlag=0 And CheckFlag=1 and Year=" & Val(.CxbbGrid.TextMatrix(Jsqte, 0)) & " and Period=" & Val(.CxbbGrid.TextMatrix(Jsqte, 1)) & " And VouchClassCode='" & Trim(.CxbbGrid.TextMatrix(Jsqte, 2)) & "' And VouchNo=" & Val(.CxbbGrid.TextMatrix(Jsqte, 3)))
  790.           
  791.        End If
  792.    Next Jsqte
  793.    
  794.   End With
  795.   
  796.   Tsxx = "全部弃审完毕!"
  797.   Call Xtxxts(Tsxx, 0, 4)
  798.   
  799.   '标识单据发生变化
  800.   Bln_BillChange = True
  802. End Sub
  805. '选择首张,上张,下张,末张
  806.     
  807.     Private Sub Sub_First()             '首 张
  808.        With PZ_FrmPzcxjg
  809.          .CxbbGrid.Select .CxbbGrid.FixedRows, 0
  810.          If Combo_Kjqj.Text = Trim((.CxbbGrid.TextMatrix(.CxbbGrid.Row, 0))) + "." + Trim((.CxbbGrid.TextMatrix(.CxbbGrid.Row, 1))) And LrText(0).Text = Trim(.CxbbGrid.TextMatrix(.CxbbGrid.Row, 2)) And Val(LrText(3).Text) = Val(.CxbbGrid.TextMatrix(.CxbbGrid.Row, 3)) Then
  811.             Exit Sub
  812.          End If
  813.             
  814.          Call Sub_ShowFindBill
  815.        
  816.        End With
  817.     End Sub
  818.     Private Sub Sub_Prev()             '上 张
  819.        With PZ_FrmPzcxjg
  820.          Do While .CxbbGrid.Row > .CxbbGrid.FixedRows And Combo_Kjqj.Text = Trim((.CxbbGrid.TextMatrix(.CxbbGrid.Row, 0))) + "." + Trim((.CxbbGrid.TextMatrix(.CxbbGrid.Row, 1))) And LrText(0).Text = Trim(.CxbbGrid.TextMatrix(.CxbbGrid.Row, 2)) And Val(LrText(3).Text) = Val(.CxbbGrid.TextMatrix(.CxbbGrid.Row, 3))
  821.             .CxbbGrid.Row = .CxbbGrid.Row - 1
  822.          Loop
  823.          If Combo_Kjqj.Text = Trim((.CxbbGrid.TextMatrix(.CxbbGrid.Row, 0))) + "." + Trim((.CxbbGrid.TextMatrix(.CxbbGrid.Row, 1))) And LrText(0).Text = Trim(.CxbbGrid.TextMatrix(.CxbbGrid.Row, 2)) And Val(LrText(3).Text) = Val(.CxbbGrid.TextMatrix(.CxbbGrid.Row, 3)) Then
  824.             Exit Sub
  825.          End If
  826.             
  827.          Call Sub_ShowFindBill
  828.        
  829.        End With
  830.     End Sub
  831.     Private Sub Sub_next()             '下 张
  832.        With PZ_FrmPzcxjg
  833.          Do While .CxbbGrid.Row < .CxbbGrid.Rows - 1 And Combo_Kjqj.Text = Trim((.CxbbGrid.TextMatrix(.CxbbGrid.Row, 0))) + "." + Trim((.CxbbGrid.TextMatrix(.CxbbGrid.Row, 1))) And LrText(0).Text = Trim(.CxbbGrid.TextMatrix(.CxbbGrid.Row, 2)) And Val(LrText(3).Text) = Val(.CxbbGrid.TextMatrix(.CxbbGrid.Row, 3))
  834.             .CxbbGrid.Row = .CxbbGrid.Row + 1
  835.          Loop
  836.          If Combo_Kjqj.Text = Trim((.CxbbGrid.TextMatrix(.CxbbGrid.Row, 0))) + "." + Trim((.CxbbGrid.TextMatrix(.CxbbGrid.Row, 1))) And LrText(0).Text = Trim(.CxbbGrid.TextMatrix(.CxbbGrid.Row, 2)) And Val(LrText(3).Text) = Val(.CxbbGrid.TextMatrix(.CxbbGrid.Row, 3)) Then
  837.             Exit Sub
  838.          End If
  839.             
  840.          Call Sub_ShowFindBill
  841.        
  842.        End With
  843.     End Sub
  844.     Private Sub Sub_Last()              '末 张
  845.        With PZ_FrmPzcxjg
  846.          .CxbbGrid.Select .CxbbGrid.Rows - 1, 0
  847.          If Combo_Kjqj.Text = Trim((.CxbbGrid.TextMatrix(.CxbbGrid.Row, 0))) + "." + Trim((.CxbbGrid.TextMatrix(.CxbbGrid.Row, 1))) And LrText(0).Text = Trim(.CxbbGrid.TextMatrix(.CxbbGrid.Row, 2)) And Val(LrText(3).Text) = Val(.CxbbGrid.TextMatrix(.CxbbGrid.Row, 3)) Then
  848.             Exit Sub
  849.          End If
  850.           
  851.          Call Sub_ShowFindBill
  852.        End With
  853.     End Sub
  854.     Private Sub Sub_ShowFindBill()      '显示用户在单据列表中查询定位单据
  855.         With PZ_FrmPzcxjg
  856.             '填充查询凭证标识
  857.              Combo_Kjqj.Text = Trim((.CxbbGrid.TextMatrix(.CxbbGrid.Row, 0))) + "." + Trim((.CxbbGrid.TextMatrix(.CxbbGrid.Row, 1)))
  858.              LrText(0).Text = Trim(.CxbbGrid.TextMatrix(.CxbbGrid.Row, 2))
  859.              LrText(3).Text = Mid(Trim(Str(10000 + Val(.CxbbGrid.TextMatrix(.CxbbGrid.Row, 3)))), 2, 4)
  860.                
  861.              Call Sub_ShowBill
  862.         End With
  863.     End Sub
  864.     
  865. Private Function Fun_AllowEdit() As Boolean                      '判断当前凭证是否允许编辑或删除
  866.   Dim RecTemp As New ADODB.Recordset     '临时使用动态集
  867.   Dim Int_Year As Integer      '用户选择会计年度
  868.   Dim Int_Period As Integer    '用户选择会计期间
  869.   
  870.   Int_Year = Val(Mid(Combo_Kjqj.Text, 1, 4))
  871.   Int_Period = Val(Mid(Combo_Kjqj.Text, 6, 2))
  872.   SQLSTR = "Select Top 1 CheckFlag,BookFlag,Checker,Book From Cwzz_AccVouch Where Rectype=0 And Year=" & Int_Year & " and Period=" & Int_Period & " And VouchClassCode='" & Trim(LrText(0).Text) & "' And VouchNo=" & Val(LrText(3).Text)
  873.   Set RecTemp = Cw_DataEnvi.DataConnect.Execute(SQLSTR)
  874.   With RecTemp
  875.      If Not .EOF Then
  876.         If .Fields("CheckFlag") Or .Fields("BookFlag") Then
  877.            Tsxx = "该凭证已审核或记帐,不允许修改或删除!"
  878.            Call Xtxxts(Tsxx, 0, 4)
  879.            Lab_Checker = Trim(.Fields("Checker") & "")
  880.            Lab_Book = Trim(.Fields("Book") & "")
  881.            Exit Function
  882.         End If
  883.       End If
  884.   End With
  885.   Fun_AllowEdit = True
  886. End Function
  887. Public Sub Sub_Scpzbb(Cxsjwg As vsFlexGrid)                            '生成预览凭证报表
  889.  '过程参数:输出数据网格
  890.  
  891.  Dim Yxhzjsq%, Yxlzjsq%       '有效列值计数器,有效行值计数器
  892.  Dim Rowjsq As Long           '临时行计数器
  893.  Dim Sjhjsq As Long           '数据行计数器
  894.  Dim Int_Pzmyhs As Integer    '凭证每页数据行数
  895.  Dim Dbl_Jfhj As Double       '借方合计
  896.  Dim Dbl_Dfhj As Double       '贷方合计
  897.  
  898.  '生成有效数据表
  899.  With DY_Tybbyldy.DyylGrid
  900.   .FontName = Cxsjwg.FontName
  901.   .FontSize = Cxsjwg.FontSize
  902.   .FixedRows = Cxsjwg.FixedRows
  903.   .MergeCells = flexMergeFixedOnly
  904.   For Jsqte = 0 To .FixedRows - 1
  905.       .MergeRow(Jsqte) = True
  906.   Next Jsqte
  907.   .WordWrap = True
  908.   
  909.   '重置数据列
  910.   Yxlzjsq = 4
  911.   .Cols = Yxlzjsq
  912.   
  913.   .ColAlignment(2) = Cxsjwg.ColAlignment(Sydz("004", GridStr(), Szzls))
  914.   .ColAlignment(3) = Cxsjwg.ColAlignment(Sydz("005", GridStr(), Szzls))
  915.   .ColWidth(0) = Cxsjwg.ColWidth(Sydz("001", GridStr(), Szzls))
  916.   .ColWidth(1) = Cxsjwg.ColWidth(Sydz("002", GridStr(), Szzls)) + Cxsjwg.ColWidth(Sydz("003", GridStr(), Szzls))
  917.   .ColWidth(2) = Cxsjwg.ColWidth(Sydz("004", GridStr(), Szzls))
  918.   .ColWidth(3) = Cxsjwg.ColWidth(Sydz("005", GridStr(), Szzls))
  919.   .ColFormat(2) = Cxsjwg.ColFormat(Sydz("004", GridStr(), Szzls))
  920.   .ColFormat(3) = Cxsjwg.ColFormat(Sydz("005", GridStr(), Szzls))
  921.   
  922.   For Yxlzjsq = 0 To 3
  923.       .MergeCol(Yxlzjsq) = True
  924.   Next Yxlzjsq
  925.   
  926.   '重置数据行
  927.   
  928.   Yxhzjsq = 0
  929.   For Rowjsq = 0 To Cxsjwg.Rows - 1
  930.       If (Not Cxsjwg.RowHidden(Rowjsq)) And (Not GridRowEmpty(Cxsjwg, Rowjsq)) Then
  931.          Yxhzjsq = Yxhzjsq + 1
  932.       End If
  933.   Next Rowjsq
  934.   .Rows = Yxhzjsq
  935.   
  936.   
  937.   .TextMatrix(0, 0) = Cxsjwg.TextMatrix(0, Sydz("001", GridStr(), Szzls))
  938.   .TextMatrix(0, 1) = "科  目  名  称"
  939.   .TextMatrix(0, 2) = Cxsjwg.TextMatrix(0, Sydz("004", GridStr(), Szzls))
  940.   .TextMatrix(0, 3) = Cxsjwg.TextMatrix(0, Sydz("005", GridStr(), Szzls))
  941.   .RowHeight(0) = Cxsjwg.RowHeight(0)
  942.   
  943.   
  944.   Yxhzjsq = Cxsjwg.FixedRows
  946.   For Rowjsq = Cxsjwg.FixedRows To Cxsjwg.Rows - 1
  947.     If (Not Cxsjwg.RowHidden(Rowjsq)) And (Not GridRowEmpty(Cxsjwg, Rowjsq)) Then
  948.        
  949.        '摘要
  950.        .TextMatrix(Yxhzjsq, 0) = Cxsjwg.TextMatrix(Rowjsq, Sydz("001", GridStr(), Szzls))
  951.        
  952.        '输出科目名称
  953.        If Chk_CodeOutput.Value = 1 Then
  954.           .TextMatrix(Yxhzjsq, 1) = Cxsjwg.TextMatrix(Rowjsq, Sydz("002", GridStr(), Szzls)) + " " + Cxsjwg.TextMatrix(Rowjsq, Sydz("003", GridStr(), Szzls))
  955.        Else
  956.           .TextMatrix(Yxhzjsq, 1) = Cxsjwg.TextMatrix(Rowjsq, Sydz("003", GridStr(), Szzls))
  957.        End If
  958.        If Trim(Cxsjwg.TextMatrix(Rowjsq, 2)) <> "" Then    '结算方式
  959.           .TextMatrix(Yxhzjsq, 1) = .TextMatrix(Yxhzjsq, 1) + Space(2) + Trim(Cxsjwg.TextMatrix(Rowjsq, 2))
  960.        End If
  961.        If Trim(Cxsjwg.TextMatrix(Rowjsq, 3)) <> "" Then    '票号
  962.           .TextMatrix(Yxhzjsq, 1) = .TextMatrix(Yxhzjsq, 1) + Space(2) + Trim(Cxsjwg.TextMatrix(Rowjsq, 3))
  963.        End If
  964.        If Trim(Cxsjwg.TextMatrix(Rowjsq, 4)) <> "" Then    '发生日期
  965.           .TextMatrix(Yxhzjsq, 1) = .TextMatrix(Yxhzjsq, 1) + Space(2) + Trim(Cxsjwg.TextMatrix(Rowjsq, 4))
  966.        End If
  967.        If Val(Cxsjwg.TextMatrix(Rowjsq, 5)) <> 0 Then      '数量
  968.           .TextMatrix(Yxhzjsq, 1) = .TextMatrix(Yxhzjsq, 1) + Space(2) + Trim(Cxsjwg.TextMatrix(Rowjsq, 5)) + Trim(Cxsjwg.TextMatrix(Rowjsq, 7))
  969.        End If
  970.        If Trim(Cxsjwg.TextMatrix(Rowjsq, 9)) <> "" Then    '外币名称
  971.           .TextMatrix(Yxhzjsq, 1) = .TextMatrix(Yxhzjsq, 1) + Space(2) + Trim(Cxsjwg.TextMatrix(Rowjsq, 10)) + Trim(Cxsjwg.TextMatrix(Rowjsq, 9))
  972.        End If
  973.        If Val(Cxsjwg.TextMatrix(Rowjsq, 11)) <> 0 Then      '记帐汇率
  974.           .TextMatrix(Yxhzjsq, 1) = .TextMatrix(Yxhzjsq, 1) + Space(2) + "汇率:" + Trim(Cxsjwg.TextMatrix(Rowjsq, 11))
  975.        End If
  976.        If Trim(Cxsjwg.TextMatrix(Rowjsq, 13)) <> "" Then    '部门
  977.           .TextMatrix(Yxhzjsq, 1) = .TextMatrix(Yxhzjsq, 1) + Space(2) + Trim(Cxsjwg.TextMatrix(Rowjsq, 13))
  978.        End If
  979.        If Trim(Cxsjwg.TextMatrix(Rowjsq, 15)) <> "" Then    '往来单位
  980.           .TextMatrix(Yxhzjsq, 1) = .TextMatrix(Yxhzjsq, 1) + Space(2) + Trim(Cxsjwg.TextMatrix(Rowjsq, 15))
  981.        End If
  982.        If Trim(Cxsjwg.TextMatrix(Rowjsq, 17)) <> "" Then    '职员
  983.           .TextMatrix(Yxhzjsq, 1) = .TextMatrix(Yxhzjsq, 1) + Space(2) + Trim(Cxsjwg.TextMatrix(Rowjsq, 17))
  984.        End If
  985.        If Trim(Cxsjwg.TextMatrix(Rowjsq, 19)) <> "" Then    '项目大类
  986.           .TextMatrix(Yxhzjsq, 1) = .TextMatrix(Yxhzjsq, 1) + Space(2) + Trim(Cxsjwg.TextMatrix(Rowjsq, 19))
  987.        End If
  988.        If Trim(Cxsjwg.TextMatrix(Rowjsq, 21)) <> "" Then    '项目名称
  989.           .TextMatrix(Yxhzjsq, 1) = .TextMatrix(Yxhzjsq, 1) + Space(2) + Trim(Cxsjwg.TextMatrix(Rowjsq, 21))
  990.        End If
  991.        If Val(Cxsjwg.TextMatrix(Rowjsq, 22)) <> 0 Then      '项目数量单位
  992.           .TextMatrix(Yxhzjsq, 1) = .TextMatrix(Yxhzjsq, 1) + Space(2) + Trim(Cxsjwg.TextMatrix(Rowjsq, 22)) + Trim(Cxsjwg.TextMatrix(Rowjsq, 23))
  993.        End If
  994.        If Trim(Cxsjwg.TextMatrix(Rowjsq, 24)) <> "" Then    '经办人
  995.           .TextMatrix(Yxhzjsq, 1) = .TextMatrix(Yxhzjsq, 1) + Space(2) + "经办人:" + Trim(Cxsjwg.TextMatrix(Rowjsq, 24))
  996.        End If
  997.        
  998.        '借方金额
  999.        .TextMatrix(Yxhzjsq, 2) = Cxsjwg.TextMatrix(Rowjsq, Sydz("004", GridStr(), Szzls))
  1000.        
  1001.        '贷方金额
  1002.        .TextMatrix(Yxhzjsq, 3) = Cxsjwg.TextMatrix(Rowjsq, Sydz("005", GridStr(), Szzls))
  1003.        
  1004.        .RowHeight(Yxhzjsq) = Cxsjwg.RowHeight(Rowjsq)
  1005.        Yxhzjsq = Yxhzjsq + 1
  1006.     End If
  1007.   Next Rowjsq
  1008.   
  1009.   '补空行和添加分页合计
  1010.   Int_Pzmyhs = 6
  1011.   
  1012.   If .Rows - .FixedRows = 0 Then
  1013.      Exit Sub
  1014.   Else
  1015.      If (.Rows - .FixedRows) Mod Int_Pzmyhs <> 0 Then
  1016.         For Jsqte = 1 To Int_Pzmyhs - ((.Rows - .FixedRows) Mod Int_Pzmyhs)
  1017.             .AddItem ""
  1018.             .RowHeight(.Rows - 1) = Sjhgd
  1019.         Next Jsqte
  1020.      End If
  1021.   End If
  1022.   
  1023.   Dbl_Jfhj = 0
  1024.   Dbl_Dfhj = 0
  1025.   Sjhjsq = 1
  1026.   Rowjsq = .FixedRows
  1027.   Do While Rowjsq <= .Rows - 1
  1028.   
  1029.       Dbl_Jfhj = Dbl_Jfhj + Val(.TextMatrix(Rowjsq, 2))
  1030.       Dbl_Dfhj = Dbl_Dfhj + Val(.TextMatrix(Rowjsq, 3))
  1031.       
  1032.       If Sjhjsq Mod Int_Pzmyhs = 0 Then
  1033.          Rowjsq = Rowjsq + 1
  1034.          .AddItem "", Rowjsq
  1035.          .RowHeight(Rowjsq) = Sjhgd
  1036.          .TextMatrix(Rowjsq, 0) = "合 计"
  1037.          .TextMatrix(Rowjsq, 2) = Format(Dbl_Jfhj, "##." + String(Xtjexsws, "0"))
  1038.          .TextMatrix(Rowjsq, 3) = Format(Dbl_Dfhj, "##." + String(Xtjexsws, "0"))
  1039.          
  1040.          '最后合计输出金额大写
  1041.          If Rowjsq = .Rows - 1 Then
  1042.             .TextMatrix(Rowjsq, 1) = Fun_Jezh(Dbl_Jfhj)
  1043.          End If
  1044.       End If
  1045.       
  1046.       Sjhjsq = Sjhjsq + 1
  1047.       Rowjsq = Rowjsq + 1
  1048.       
  1049.   Loop
  1050.  End With
  1051.  
  1052. End Sub
  1054. '===================以 下 程 序 为 通 用 部 分 ,一 般 不 需 更 改======================='
  1055. Private Sub Sub_AdjustGrid()
  1056.   '调 整 网 格
  1057.   With WglrGrid
  1058.     '加 1 保持一行录入行
  1059.      If .Rows < Pmbcsjhs + .FixedRows + Fzxwghs + 1 Then
  1060.         .Rows = Pmbcsjhs + .FixedRows + Fzxwghs + 1
  1061.            For Jsqte = .FixedRows To .Rows - 1
  1062.              .RowHeight(Jsqte) = Sjhgd
  1063.            Next Jsqte
  1064.      Else
  1065.         '判断是否有辅助行和录入行,如没有则加行
  1066.         Do While .TextMatrix(.Rows - 1 - Fzxwghs, 0) = "*"
  1067.           .AddItem ""
  1068.           .RowHeight(.Rows - 1) = Sjhgd
  1069.         Loop
  1070.      End If
  1071.   End With
  1072. End Sub
  1073. Private Sub Lrzdbz()                                                      '录入字段帮助
  1074.    If Not Ydcommand.Visible Then
  1075.       Exit Sub
  1076.    End If
  1077.   Valilock = True
  1078.   With WglrGrid
  1079.        
  1080.        '[>>会计科目编码帮助单独处理
  1081.        If .Col = Sydz("002", GridStr(), Szzls) Then
  1082.           Xtcdcs = Trim(Ydtext.Text)
  1083.           PZ_FrmKjkmcz.Show 1
  1084.           If Len(Xtfhcs) <> 0 Then
  1085.              Ydtext.Text = Xtfhcs
  1086.           End If
  1087.        Else
  1088.         
  1089.             '处理通用部分
  1090.             changelock = True        '调入另外窗体必须加锁
  1091.                Call Drbmhelp(GridInt(.Col, 6), GridStr(.Col, 3), Trim(Ydtext.Text))
  1092.             changelock = False
  1093.             If Len(Xtfhcs) <> 0 Then
  1094.                If GridInt(.Col, 7) = 0 Then
  1095.                   Ydtext.Text = Xtfhcs
  1096.                Else
  1097.                   Ydtext.Text = Xtfhcsfz
  1098.                End If
  1099.             End If
  1100.         End If
  1101.         '[>>处理完毕
  1102.         
  1103.   Valilock = False
  1104.   If Ydtext.Visible Then
  1105.     Ydtext.SetFocus
  1106.   End If
  1107.  End With
  1108. End Sub
  1109. Private Sub Cshhjwg()                                                     '初始化合计网格(*对合计网格来说,录入网格为容器)
  1110.    Dim Lrwglkd As Double
  1111.    Dim Hjwgpyl As Integer
  1112.  With HjGrid
  1113.    If Not Sfxshjwg Then
  1114.       .Visible = False
  1115.       Exit Sub
  1116.      Else
  1117.       .Visible = True
  1118.    End If
  1119.      .Enabled = False
  1120.      .Appearance = flexFlat
  1121.      .BorderStyle = flexBorderNone
  1122.      .ScrollBars = flexScrollBarNone
  1123.      .BackColor = &H80000018
  1124.      .Width = WglrGrid.Width
  1125.      .FixedRows = 0
  1126.      .Rows = 1
  1127.      .Cols = WglrGrid.Cols
  1128.      .LeftCol = WglrGrid.LeftCol
  1129.      .TextMatrix(0, Qslz) = "合  计"
  1130.      For Jsqte = 0 To WglrGrid.Cols - 1
  1131.         .ColHidden(Jsqte) = WglrGrid.ColHidden(Jsqte)
  1132.         .ColWidth(Jsqte) = WglrGrid.ColWidth(Jsqte)
  1133.         .ColAlignment(Jsqte) = WglrGrid.ColAlignment(Jsqte)
  1134.         .ColFormat(Jsqte) = WglrGrid.ColFormat(Jsqte)
  1135.      Next Jsqte
  1136.      .ColAlignment(Qslz) = flexAlignCenterTop
  1137.      For Jsqte = .FixedRows To .Rows - 1
  1138.          .RowHeight(Jsqte) = .Height / .Rows
  1139.      Next Jsqte
  1140.      .Move 0, WglrGrid.Height - .Height, WglrGrid.Width, .Height
  1141.    End With
  1142. End Sub
  1143. Private Sub Form_Resize()                                                '窗体大小发生变化时,重新显示文本框
  1144.    Call Cxxswbk
  1145. End Sub
  1146. Private Function Fun_Drfrmyxxpd() As Boolean                             '调入其它窗体或功能产生的有效性判断(包括数据回写)
  1147.   Fun_Drfrmyxxpd = True
  1148.   With WglrGrid
  1149.    
  1150.    '如果当前网格处于编辑状态,则先进行数据回写再进行有效性判断
  1151.   
  1152.    If Ydtext.Visible Or YdCombo.Visible Then
  1153.         Call Lrsjhx
  1154.         If Not sjzdyxxpd(Dqlrwgh, Dqlrwgl) Then
  1155.            Fun_Drfrmyxxpd = False
  1156.            Exit Function
  1157.         End If
  1158.    End If
  1159.    
  1160.    '进行行有效性判断
  1161.    If Not Sjhzyxxpd(.Row) Then
  1162.       Fun_Drfrmyxxpd = False
  1163.       Exit Function
  1164.    End If
  1165.    
  1166.   End With
  1167. End Function
  1169. Private Sub WglrGrid_AfterUserResize(ByVal Row As Long, ByVal Col As Long)       '调整列宽
  1170.    If HjGrid.Visible Then
  1171.       With HjGrid
  1172.          .ColWidth(Col) = WglrGrid.ColWidth(Col)
  1173.       End With
  1174.    End If
  1175. End Sub
  1176. Private Sub WglrGrid_EnterCell()                                    '显示当前数据行相关信息
  1177.    With WglrGrid
  1178.     If .Row >= .FixedRows Then
  1179.        Lab_Row = Trim(Str(.Row - .FixedRows + 1))
  1181.        '显示备注信息
  1182.        Call Sub_ShowMemo(WglrGrid.Row)
  1183.     End If
  1184.    End With
  1185. End Sub
  1187. Private Sub WglrGrid_GotFocus()                                     '网格得到焦点
  1189.   '网格得到焦点,如果当前选择行为非数据行
  1190.   '则调整当前焦点至有效数据行
  1192.     With WglrGrid
  1193.       If .Row < .FixedRows And .Rows > .FixedRows Then
  1194.          changelock = True
  1195.           .Select .FixedRows, .Col
  1196.          changelock = False
  1197.       End If
  1198.       If .Col < Qslz Then
  1199.          changelock = True
  1200.           .Select .Row, Qslz
  1201.          changelock = False
  1202.       End If
  1203.     End With
  1205. End Sub
  1208. Private Sub WglrGrid_LostFocus()                                    '录入网格失去焦点
  1210.   '用以屏蔽调用其它窗体时发生网格失去焦点事件
  1211.   If changelock Then
  1212.      Exit Sub
  1213.   End If
  1215.   '引发网格RowcolChange事件
  1216.   With WglrGrid
  1217.     If Not (Ydtext.Visible Or YdCombo.Visible) Then
  1218.        .Select 0, 0
  1219.     End If
  1220.   End With
  1222. End Sub
  1223. Private Sub WglrGrid_Scroll()                                       '限制用户在录入过程中滚动鼠标
  1225.  If Gdtlock Then
  1226.     Exit Sub
  1227.  End If
  1228.  
  1229.  With WglrGrid
  1230.   If Ydtext.Visible Or YdCombo.Visible Then
  1231.      Gdtlock = True
  1232.      .TopRow = Dqtoprow
  1233.      .LeftCol = Dqleftcol
  1234.      Gdtlock = False
  1235.      Exit Sub
  1236.   End If
  1237.   HjGrid.LeftCol = .LeftCol
  1238.  End With
  1239. End Sub
  1240. Private Sub WglrGrid_LeaveCell()                                    '离开单元格
  1241.   If changelock Then
  1242.      Exit Sub
  1243.   End If
  1245.   '记录刚刚离开网格单元的行列值
  1246.   Dqlkwgh = WglrGrid.Row
  1247.   Dqlkwgl = WglrGrid.Col
  1249.   '判断是否需要录入数据回写
  1250.   If Not (Ydtext.Visible Or YdCombo.Visible) Then
  1251.      Exit Sub
  1252.   End If
  1253.   Call Lrsjhx
  1254. End Sub
  1255. Private Sub WglrGrid_RowColChange()                                '网格录入行列发生变化时,进行有效性判断
  1256.    Valilock = True       '屏蔽文本框失去焦点进行有效性判断
  1257.    With WglrGrid
  1258.      If changelock Then
  1259.         Exit Sub
  1260.      End If
  1261.      If Not sjzdyxxpd(Dqlrwgh, Dqlrwgl) Then
  1262.         Exit Sub
  1263.      End If
  1264.      If .Row <> Dqlkwgh Then
  1265.         If Not Sjhzyxxpd(Dqlkwgh) Then
  1266.            Exit Sub
  1267.         End If
  1268.      End If
  1269.    End With
  1270.    Call fhyxh
  1271.    Call Xldql
  1272.    
  1273. End Sub
  1274. Private Sub WglrGrid_DblClick()          '鼠标双击网格显示文本框
  1275.   With WglrGrid
  1276.     Call xswbk
  1277.   End With
  1278. End Sub
  1279. Private Sub Ycwbk()                      '隐藏文本框,帮助按钮,列表组合框
  1280.  Valilock = True
  1281.    Ydtext.Visible = False
  1282.    YdCombo.Visible = False
  1283.    Ydcommand.Visible = False
  1284. End Sub
  1285. Private Sub YdCombo_KeyDown(KeyCode As Integer, Shift As Integer)        '列表框移动
  1286.   With WglrGrid
  1287.     Select Case KeyCode
  1288.       Case vbKeyEscape                'ESC 键放弃录入
  1289.            Valilock = True
  1290.             .SetFocus
  1291.             Call Ycwbk
  1292.            Valilock = False
  1293.       Case vbKeyReturn                '回 车 键 =13
  1294.            KeyCode = 0
  1295.            .SetFocus
  1296.            Call Lrsjhx
  1297.            Rowjsq = .Row
  1298.            Coljsq = .Col + 1
  1299.            If Coljsq > .Cols - 1 Then
  1300.               If Rowjsq < .Rows - 1 Then
  1301.                  Rowjsq = Rowjsq + 1
  1302.               End If
  1303.               Coljsq = Qslz
  1304.            End If
  1305.            Do While Rowjsq <= .Rows - 1
  1306.               If .ColHidden(Coljsq) Or (Not GridBoolean(Coljsq, 1)) Then
  1307.                  Coljsq = Coljsq + 1
  1308.                  If Coljsq > .Cols - 1 Then
  1309.                     Rowjsq = Rowjsq + 1
  1310.                     Coljsq = Qslz
  1311.                  End If
  1312.               Else
  1313.                  Exit Do
  1314.               End If
  1315.             Loop
  1316.             .Select Rowjsq, Coljsq
  1317.        Case vbKeyLeft                  '左 箭 头 =37
  1318.            If .Col - 1 = Qslz Then
  1319.               If .ColHidden(Qslz) Or (Not GridBoolean(Qslz, 1)) Then
  1320.                  GoTo jzzx
  1321.               End If
  1322.            End If
  1323.            If .Col > Qslz Then
  1324.               KeyCode = 0
  1325.               .SetFocus
  1326.               Call Lrsjhx
  1327.               Coljsq = .Col - 1
  1328.               Do While Coljsq > Qslz
  1329.                  If Coljsq - 1 = Qslz Then
  1330.                     If .ColHidden(Qslz) Or (Not GridBoolean(Qslz, 1)) Then
  1331.                        GoTo jzzx
  1332.                     End If
  1333.                  End If
  1334.                  If .ColHidden(Coljsq) Or (Not GridBoolean(Coljsq, 1)) Then
  1335.                     Coljsq = Coljsq - 1
  1336.                  Else
  1337.                       Exit Do
  1338.                  End If
  1339.                Loop
  1340.                .Select .Row, Coljsq
  1341.            End If
  1343.       Case vbKeyRight                 '右 箭 头 =39
  1344.             KeyCode = 0
  1345.             .SetFocus
  1346.             Call Lrsjhx
  1347.              Rowjsq = .Row
  1348.              Coljsq = .Col + 1
  1349.              If Coljsq > .Cols - 1 Then
  1350.                 If Rowjsq < .Rows - 1 Then
  1351.                    Rowjsq = Rowjsq + 1
  1352.                 End If
  1353.                 Coljsq = Qslz
  1354.              End If
  1355.              Do While Rowjsq <= .Rows - 1
  1356.                 If .ColHidden(Coljsq) Or (Not GridBoolean(Coljsq, 1)) Then
  1357.                    Coljsq = Coljsq + 1
  1358.                    If Coljsq > .Cols - 1 Then
  1359.                       Rowjsq = Rowjsq + 1
  1360.                       Coljsq = Qslz
  1361.                    End If
  1362.                 Else
  1363.                    Exit Do
  1364.                 End If
  1365.               Loop
  1366.               .Select Rowjsq, Coljsq
  1367.       Case Else
  1368.    End Select
  1369.    
  1370. jzzx:
  1371.    
  1372.  End With
  1373. End Sub
  1374. Private Sub YdCombo_LostFocus()
  1375.   With WglrGrid                                    '因为选中网格会先发生Rowcolchange事件置Valiock
  1376.     If Not Valilock Then                           '为TRUE
  1377.        Call Lrsjhx
  1378.        If Not Sjhzyxxpd(Dqlrwgh) Then
  1379.           Exit Sub
  1380.        End If
  1381.     End If
  1382.   End With
  1383. End Sub
  1384. Private Sub Ydcommand_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
  1385.    Call Lrzdbz
  1386. End Sub
  1387. Private Sub ydtext_KeyDown(KeyCode As Integer, Shift As Integer)
  1388.    Dim Rowjsq As Long, Coljsq As Long
  1389.   With WglrGrid
  1390.     Select Case KeyCode
  1391.       Case vbKeyF2
  1392.            Call Lrzdbz
  1393.       Case vbKeyEscape                'ESC 键放弃录入
  1394.            Valilock = True
  1395.             Call Ycwbk
  1396.            .SetFocus
  1397.       Case vbKeyReturn                '回 车 键 =13
  1398.            KeyCode = 0
  1399.            .SetFocus
  1400.            Call Lrsjhx
  1401.            Rowjsq = .Row
  1402.            Coljsq = .Col + 1
  1403.            If Coljsq > .Cols - 1 Then
  1404.               If Rowjsq < .Rows - 1 Then
  1405.                  Rowjsq = Rowjsq + 1
  1406.               End If
  1407.               Coljsq = Qslz
  1408.            End If
  1409.            Do While Rowjsq <= .Rows - 1
  1410.               If .ColHidden(Coljsq) Or (Not GridBoolean(Coljsq, 1)) Then
  1411.                  Coljsq = Coljsq + 1
  1412.                  If Coljsq > .Cols - 1 Then
  1413.                     Rowjsq = Rowjsq + 1
  1414.                     Coljsq = Qslz
  1415.                  End If
  1416.               Else
  1417.                  Exit Do
  1418.               End If
  1419.             Loop
  1420.             .Select Rowjsq, Coljsq
  1421.       Case vbKeyUp                    '上 箭 头 =38
  1422.            KeyCode = 0
  1423.            .SetFocus
  1424.            Call Lrsjhx
  1425.            If .Row > .FixedRows Then
  1426.               .Row = .Row - 1
  1427.            End If
  1428.       Case vbKeyDown                  '下 箭 头 =40
  1429.            KeyCode = 0
  1430.            .SetFocus
  1431.            Call Lrsjhx
  1432.            If .Row < .Rows - 1 Then
  1433.               .Row = .Row + 1
  1434.            End If
  1435.        Case vbKeyLeft                  '左 箭 头 =37
  1436.            If .Col - 1 = Qslz Then
  1437.               If .ColHidden(Qslz) Or (Not GridBoolean(Qslz, 1)) Then
  1438.                  GoTo jzzx
  1439.               End If
  1440.            End If
  1441.            If Ydtext.SelStart = 0 And .Col > Qslz Then
  1442.               KeyCode = 0
  1443.               .SetFocus
  1444.               Call Lrsjhx
  1445.               Coljsq = .Col - 1
  1446.               Do While Coljsq > Qslz
  1447.                  If Coljsq - 1 = Qslz Then
  1448.                     If .ColHidden(Qslz) Or (Not GridBoolean(Qslz, 1)) Then
  1449.                        GoTo jzzx
  1450.                     End If
  1451.                  End If
  1452.                  If .ColHidden(Coljsq) Or (Not GridBoolean(Coljsq, 1)) Then
  1453.                     Coljsq = Coljsq - 1
  1454.                  Else
  1455.                       Exit Do
  1456.                  End If
  1457.                Loop
  1458.                .Select .Row, Coljsq
  1459.            End If
  1460. jzzx:
  1461.            
  1462.            
  1463.       Case vbKeyRight                 '右 箭 头 =39
  1464.             wblong = Len(Ydtext.Text)
  1465.             If (Ydtext.SelStart = wblong Or Ydtext.SelLength = wblong) Then
  1466.                KeyCode = 0
  1467.                .SetFocus
  1468.                Call Lrsjhx
  1469.                 Rowjsq = .Row
  1470.                 Coljsq = .Col + 1
  1471.                 If Coljsq > .Cols - 1 Then
  1472.                    If Rowjsq < .Rows - 1 Then
  1473.                       Rowjsq = Rowjsq + 1
  1474.                    End If
  1475.                    Coljsq = Qslz
  1476.                 End If
  1477.                 Do While Rowjsq <= .Rows - 1
  1478.                    If .ColHidden(Coljsq) Or (Not GridBoolean(Coljsq, 1)) Then
  1479.                       Coljsq = Coljsq + 1
  1480.                       If Coljsq > .Cols - 1 Then
  1481.                          Rowjsq = Rowjsq + 1
  1482.                          Coljsq = Qslz
  1483.                       End If
  1484.                    Else
  1485.                       Exit Do
  1486.                    End If
  1487.                  Loop
  1488.                  .Select Rowjsq, Coljsq
  1489.                End If
  1490.       Case Else
  1491.    End Select
  1492.  End With
  1493. End Sub
  1494. Private Sub ydtext_KeyPress(KeyAscii As Integer)         '录入字符事中控制
  1495.   Call InputFieldLimit(Ydtext, GridInt(WglrGrid.Col, 1), KeyAscii)
  1496.   If KeyAscii <> 0 Then
  1497.      Call Xyxhbz(Dqlrwgh)
  1498.   End If
  1499. End Sub
  1500. Private Sub ydtext_Change()                              '录入事中变化处理
  1502.   '防止程序改变但不进行处理
  1504.   If Wbkbhlock Then
  1505.      Exit Sub
  1506.   End If
  1508.   With WglrGrid
  1510.     '限制字段录入长度
  1511.      Wbkbhlock = True
  1512.        Select Case GridInt(.Col, 1)
  1513.           Case 8
  1514.             Call Sjgskz(Ydtext, Xtjezws - Xtjexsws - 1, Xtjexsws)
  1515.           Case 9
  1516.             Call Sjgskz(Ydtext, Xtslzws - Xtslxsws - 1, Xtslxsws)
  1517.           Case 10
  1518.             Call Sjgskz(Ydtext, Xtdjzws - Xtdjxsws - 1, Xtdjxsws)
  1519.           Case Else
  1520.              If GridInt(.Col, 3) <> 0 Or GridInt(.Col, 4) <> 0 Then
  1521.                 Call Sjgskz(Ydtext, GridInt(.Col, 3), GridInt(.Col, 4))
  1522.              End If
  1523.        End Select
  1524.       Wbkbhlock = False
  1525.   End With
  1526. End Sub
  1527. Private Sub ydtext_LostFocus()            '如果由于选中网格之外的控件而发生有效性判断(选中网格会先发生Rowcolchange事件置Valiock为TRUE)
  1528.   With WglrGrid
  1529.     If Not Valilock Then
  1530.        Call Lrsjhx
  1531.        If Not sjzdyxxpd(Dqlrwgh, Dqlrwgl) Then
  1532.           Exit Sub
  1533.        End If
  1534.        If Not Sjhzyxxpd(Dqlrwgh) Then
  1535.           Exit Sub
  1536.        End If
  1537.     End If
  1538.   End With
  1539. End Sub
  1540. Private Sub xswbk()                       '在当前选中单元显示文本框,列表框,帮助按钮(通用)
  1541.   Dim Wbkpy As Integer, Wbkpy1 As Integer '文本框偏移量
  1542.   
  1543.   '如果单据操作状态为浏览状态则不能显示录入载体
  1544.    If Trim(Lab_OperStatus.Caption) = "1" Then
  1545.       Exit Sub
  1546.    End If
  1547.      
  1548.   '显示文本框前返回有效行列（解决滚动条问题）
  1549.   Call Xldqh
  1550.   Call Xldql
  1551.   
  1552.   '隐藏文本框,帮助按钮,列表组合框
  1553.   Call Ycwbk
  1554.   
  1555.   With WglrGrid
  1556.     Dqlrwgh = .Row
  1557.     Dqlrwgl = .Col
  1558.     If Not GridBoolean(.Col, 1) Or .Row < .FixedRows Then
  1559.        Exit Sub
  1560.     End If
  1561.      
  1562.     Wbkpy = 30
  1563.     Wbkpy1 = 15
  1564.     
  1565.     If GridBoolean(.Col, 3) Then
  1566.        YdCombo.Left = .CellLeft + .Left + Wbkpy
  1567.        YdCombo.Top = .CellTop + .Top + Wbkpy
  1568.        YdCombo.Width = .CellWidth - Wbkpy1
  1569.        Call Wbkcl
  1570.        YdCombo.Visible = True
  1571.        YdCombo.SetFocus
  1572.        Ydcommand.Visible = False
  1573.        Ydtext.Visible = False
  1574.     Else
  1575.       If GridBoolean(.Col, 2) Then
  1576.         Ydcommand.Left = .Left + .CellLeft + .CellWidth - Ydcommand.Width + Wbkpy
  1577.         Ydcommand.Top = .Top + .CellTop + .CellHeight - Ydcommand.Height + Wbkpy
  1578.         Ydcommand.Visible = True
  1579.       Else
  1580.         Ydcommand.Visible = False
  1581.       End If
  1582.      
  1583.       Ydtext.Left = .CellLeft + .Left + Wbkpy
  1584.       Ydtext.Top = .CellTop + .Top + Wbkpy
  1585.       If Ydcommand.Visible Then
  1586.         If Sfblbzkd Then
  1587.          Ydtext.Width = .CellWidth - Ydcommand.Width
  1588.         Else
  1589.          Ydtext.Width = .CellWidth - Wbkpy1
  1590.         End If
  1591.       Else
  1592.          Ydtext.Width = .CellWidth - Wbkpy1
  1593.       End If
  1594.       Ydtext.Height = .CellHeight - Wbkpy1
  1595.       
  1596.       If GridInt(.Col, 2) <> 0 Then
  1597.          Ydtext.MaxLength = GridInt(.Col, 2)
  1598.       Else
  1599.          Ydtext.MaxLength = 3000
  1600.       End If
  1601.       
  1602.       Call Wbkcl
  1603.       
  1604.       Ydtext.Visible = True
  1605.       Ydtext.SetFocus
  1606.     End If
  1607.     Dqtoprow = .TopRow
  1608.     Dqleftcol = .LeftCol
  1609.     
  1610.     '重置锁值
  1611.     Valilock = False
  1612.     Wbkbhlock = False
  1613.  End With
  1614. End Sub
  1615. Private Sub Cxxswbk()                                                  'Formresize中重新显示文本框,列表框,帮助按钮(通用)
  1616.                    
  1617.   Dim Wbkpy As Integer, Wbkpy1 As Integer
  1618.   Wbkpy = 30
  1619.   Wbkpy1 = 15
  1620.   With WglrGrid
  1621.      If YdCombo.Visible Then
  1622.        YdCombo.Left = .CellLeft + .Left + Wbkpy
  1623.        YdCombo.Top = .CellTop + .Top + Wbkpy
  1624.        YdCombo.Width = .CellWidth - Wbkpy1
  1625.      End If
  1626.      If Ydcommand.Visible Then
  1627.        Ydcommand.Left = .Left + .CellLeft + .CellWidth - Ydcommand.Width + Wbkpy
  1628.        Ydcommand.Top = .Top + .CellTop + .CellHeight - Ydcommand.Height + Wbkpy
  1629.      End If
  1630.      If Ydtext.Visible Then
  1631.        If Ydcommand.Visible Then
  1632.          If Sfblbzkd Then
  1633.          Ydtext.Width = .CellWidth - Ydcommand.Width
  1634.         Else
  1635.          Ydtext.Width = .CellWidth - Wbkpy1
  1636.         End If
  1637.        Else
  1638.          Ydtext.Width = .CellWidth - Wbkpy1
  1639.        End If
  1640.       
  1641.        Ydtext.Left = .CellLeft + .Left + Wbkpy
  1642.        Ydtext.Top = .CellTop + .Top + Wbkpy
  1643.        Ydtext.Height = .CellHeight - Wbkpy1
  1644.      End If
  1645.    End With
  1647. End Sub
  1648. Private Sub Lrsjhx()                                                   '文本框录入数据回写
  1649.   With WglrGrid
  1650.    If YdCombo.Visible Then
  1651.     .Text = Trim(YdCombo.Text)
  1652.    End If
  1653.    If Ydtext.Visible Then
  1654.     .Text = Trim(Ydtext.Text)
  1655.    End If
  1656.    
  1657.    '(如果字段录入内容发生变化,则打开有效性判断锁)
  1658.    If Zdlrqnr <> Trim(.Text) Then
  1659.       Yxxpdlock = False
  1660.       Hyxxpdlock = False
  1661.    End If
  1662.    
  1663.    '如果字段录入内容不为空则写数据行有效性标志
  1664.    
  1665.    If Len(Trim(.Text)) <> 0 Then
  1666.       Call Xyxhbz(.Row)
  1667.    End If
  1668.    
  1669.    '隐藏文本框,帮助按钮,列表组合框
  1670.    Call Ycwbk
  1671.    
  1672.   End With
  1673. End Sub
  1674. Private Sub WglrGrid_KeyDown(KeyCode As Integer, Shift As Integer)    '网格录入增行，删行快捷键
  1675.   
  1676.   '如果单据操作状态为浏览状态则不能显示录入载体
  1677.   If Trim(Lab_OperStatus.Caption) = "1" Then
  1678.       Exit Sub
  1679.   End If
  1681.   Select Case KeyCode
  1682.      Case vbKeyDelete               '删行
  1683.        Call Scdqfl
  1684.      Case vbKeyInsert               '增行
  1685.        Call zjlrfl
  1686.   End Select
  1687. End Sub
  1688. Private Sub WglrGrid_KeyPress(KeyAscii As Integer)                     '网格接受键盘录入
  1689.   Dim Str_ChangeTe As String    '临时交换内容
  1690.   Dim Coljsq As Long            '临时列计数器
  1691.   Dim Int_SaveKey As Integer    '保存KeyAscii值
  1693.   '如果单据操作状态为浏览状态则不能显示录入载体
  1694.   If Trim(Lab_OperStatus.Caption) = "1" Then
  1695.       Exit Sub
  1696.   End If
  1698.   Int_SaveKey = KeyAscii
  1700.   With WglrGrid
  1701.     '屏 蔽 回 车 键
  1702.    If KeyAscii = vbKeyReturn Then
  1703.        KeyAscii = 0
  1704.        Rowjsq = .Row
  1705.         Coljsq = .Col + 1
  1706.         If Coljsq > .Cols - 1 Then
  1707.            If Rowjsq < .Rows - 1 Then
  1708.               Rowjsq = Rowjsq + 1
  1709.            End If
  1710.            Coljsq = Qslz
  1711.         End If
  1712.         Do While Rowjsq <= .Rows - 1
  1713.            If .ColHidden(Coljsq) Or (Not GridBoolean(Coljsq, 1)) Then
  1714.               Coljsq = Coljsq + 1
  1715.               If Coljsq > .Cols - 1 Then
  1716.                  Rowjsq = Rowjsq + 1
  1717.                  Coljsq = Qslz
  1718.               End If
  1719.            Else
  1720.               Exit Do
  1721.            End If
  1722.          Loop
  1723.          .Select Rowjsq, Coljsq
  1724.       Exit Sub
  1725.     End If
  1726.     '接受用户录入
  1727.   Select Case KeyAscii
  1728.      Case 0 To 32
  1730.           '[>>开始 当用户输入空格时,如果在摘要列则自动填入上条记录录入的摘要内容
  1731.           ' 如果在金额列则交换借贷内容,此段程序不要求有效性判断,否则应另行处理
  1732.             Select Case GridStr(.Col, 1)
  1733.                Case "001"   '摘要
  1734.                 If Len(Trim(WglrGrid.TextMatrix(.Row, .Col))) = 0 And Len(Trim(Str_Digest)) <> 0 Then
  1736.                    WglrGrid.TextMatrix(.Row, .Col) = Str_Digest
  1738.                    '写有效行数据标志,并打开行有效性判断锁
  1739.                    Call Xyxhbz(.Row)
  1740.                    Hyxxpdlock = False
  1741.                 End If
  1742.                Case "004", "005"  '借方金额,贷方金额
  1743.                 If Val(WglrGrid.TextMatrix(.Row, .Col)) = 0 Then
  1744.                      Str_ChangeTe = WglrGrid.TextMatrix(.Row, Sydz("004", GridStr(), Szzls))
  1746.                      WglrGrid.TextMatrix(.Row, Sydz("004", GridStr(), Szzls)) = WglrGrid.TextMatrix(.Row, Sydz("005", GridStr(), Szzls))
  1748.                      WglrGrid.TextMatrix(.Row, Sydz("005", GridStr(), Szzls)) = Str_ChangeTe
  1750.                       '写有效行数据标志,并打开行有效性判断锁
  1751.                       Call Xyxhbz(.Row)
  1752.                       Hyxxpdlock = False
  1754.                      '计算合计数据
  1755.                      For Coljsq = Qslz To .Cols - 1
  1756.                          Call Sjhj(Coljsq)
  1757.                      Next Coljsq
  1758.                  End If
  1759.             End Select
  1761.           '完毕<<]
  1764.           '显示录入载体
  1765.           Call xswbk
  1767.      Case Else
  1769.            '防止非编辑字段SendKeys()出现死循环
  1770.           If Not GridBoolean(.Col, 1) Or .Row < .FixedRows Then
  1771.              Exit Sub
  1772.           End If
  1774.           If GridBoolean(.Col, 3) Then
  1776.              '列表框录入
  1777.              Call xswbk
  1779.           Else
  1781.              '[>>开始 如果用户在借贷金额位置按"="且当前行金额为零则自动计算借贷合计差额填入录入文本框
  1782.              If Chr(KeyAscii) = "=" And (Val(.TextMatrix(.Row, Sydz("004", GridStr(), Szzls))) = 0 And Val(.TextMatrix(.Row, Sydz("005", GridStr(), Szzls))) = 0) Then
  1783.                 Select Case GridStr(.Col, 1)
  1784.                   Case "004"   '借方金额
  1785.                     Ydtext.Text = ""
  1786.                     Call Xyxhbz(.Row)
  1787.                     Call xswbk
  1788.                     Ydtext.Text = Format(Val(HjGrid.TextMatrix(0, Sydz("005", GridStr(), Szzls))) - Val(HjGrid.TextMatrix(0, .Col)), "##." + String(Xtjexsws, "0"))
  1789.                   Case "005"   '贷方金额
  1790.                     Ydtext.Text = ""
  1791.                     Call Xyxhbz(.Row)
  1792.                     Call xswbk
  1793.                     Ydtext.Text = Format(Val(HjGrid.TextMatrix(0, Sydz("004", GridStr(), Szzls))) - Val(HjGrid.TextMatrix(0, .Col)), "##." + String(Xtjexsws, "0"))
  1795.                 End Select
  1797.                 '完毕<<]
  1798.              Else
  1800.                 Ydtext.Text = ""
  1801.                 Call InputFieldLimit(Ydtext, GridInt(WglrGrid.Col, 1), KeyAscii)
  1802.                 If KeyAscii = 0 Then
  1803.                    Exit Sub
  1804.                 End If
  1806.                 '写有效行数据标志
  1807.                 Call Xyxhbz(.Row)
  1808.                 Call xswbk
  1809.                 Ydtext.Text = ""
  1810.                 Valilock = True
  1811.                   SendKeys Chr(KeyAscii), wait
  1812.                   DoEvents
  1813.                 Valilock = False
  1814.              End If
  1816.           End If
  1817.      End Select
  1818.   End With
  1819. End Sub
  1820. Private Sub zjlrfl()                                                    '增加录入分录
  1821.   With WglrGrid
  1822.     If Not (Ydtext.Visible Or YdCombo.Visible) Then
  1823.        If Not Fun_Drfrmyxxpd Then
  1824.           Exit Sub
  1825.        End If
  1826.     Else
  1827.        Exit Sub
  1828.     End If
  1829.     If .Row < .FixedRows Then
  1830.        Exit Sub
  1831.     End If
  1832.     .AddItem "", .Row
  1833.     .RowHeight(.Row) = Sjhgd
  1834.     If .Row <> .Rows - 1 Then
  1835.        If .TextMatrix(.Row + 1, 0) = "*" Then
  1836.           .TextMatrix(.Row, 0) = "*"
  1837.        Else
  1838.           .RemoveItem .Rows - 1
  1839.        End If
  1840.     End If
  1841.     Call Xldqh
  1842.     Call Xldql
  1843.     Hyxxpdlock = False
  1844.   End With
  1845. End Sub
  1846. Private Sub Scdqfl()                                                    '删除当前分录
  1847.  Dim Answer As Integer, Scqwghz As Long, Scqwglz As Long, Hjlzte As Long, Sflrzt As Boolean
  1848.  With WglrGrid
  1849.     Scqwghz = .Row
  1850.     Scqwglz = .Col
  1851.     If .TextMatrix(.Row, 0) = "*" Then
  1852.     
  1853.         '判断是否为录入状态
  1854.         If Ydtext.Visible Or YdCombo.Visible Then
  1855.           Sflrzt = True
  1856.           Validate = True
  1857.            Call Lrsjhx
  1858.           Validate = False
  1859.         End If
  1860.        
  1861.        Call Xldqh
  1862.        changelock = True
  1863.          .Select .Row, 0
  1864.        changelock = False
  1865.        If Shsfts Then
  1866.           .Cell(flexcpBackColor, .Row, Qslz, .Row, .Cols - 1) = QBColor(12)
  1867.           Tsxx = "请确认是否删除当前记录?"
  1868.           Yhanswer = Xtxxts(Tsxx, 2, 2)
  1869.           If Yhanswer = 2 Then
  1870.              .Cell(flexcpBackColor, .Row, Qslz, .Row, .Cols - 1) = &H80000005
  1871.               changelock = True
  1872.                 .Select Scqwghz, Scqwglz
  1873.               changelock = False
  1874.               
  1875.               '如为录入状态,则恢复录入
  1876.               If Sflrzt Then
  1877.                  Call xswbk
  1878.               End If
  1879.               
  1880.              Exit Sub
  1881.           End If
  1882.        End If
  1883.       .RemoveItem .Row
  1884.        If .Rows < Pmbcsjhs + .FixedRows + Fzxwghs + 1 Then
  1885.           .AddItem ""
  1886.           .RowHeight(.Rows - 1) = Sjhgd
  1887.        End If
  1888.        changelock = True
  1889.          .Select .Row, Scqwglz
  1890.        changelock = False
  1891.        
  1892.        '重新计算合计数据
  1893.        For Hjlzte = Qslz To .Cols - 1
  1894.            Call Sjhj(Hjlzte)
  1895.        Next Hjlzte
  1896.        
  1897.     End If
  1898.  End With
  1899. End Sub
  1900. Private Sub Sjhj(Hjwgl As Long)                                         '网格列数据合计
  1901.  Dim Hjjg As Double
  1902.  If Not (GridBoolean(Hjwgl, 4) And HjGrid.Visible) Then
  1903.     Exit Sub
  1904.  End If
  1905.  With WglrGrid
  1906.    Hjjg = 0
  1907.    For Jsqte = .FixedRows To .Rows - 1
  1908.        If .TextMatrix(Jsqte, 0) = "*" Then
  1909.           Hjjg = Hjjg + Val(.TextMatrix(Jsqte, Hjwgl))
  1910.        End If
  1911.    Next Jsqte
  1912.    If GridBoolean(Hjwgl, 5) And Hjjg = 0 Then
  1913.       HjGrid.TextMatrix(0, Hjwgl) = ""
  1914.    Else
  1915.       HjGrid.TextMatrix(0, Hjwgl) = Hjjg
  1916.    End If
  1917.  End With
  1918. End Sub
  1919. Private Sub Qkwlzd(sjh As Long, Sjl As Long)                            '清空为零字段
  1920.   If Not GridBoolean(Sjl, 5) Then
  1921.      Exit Sub
  1922.   End If
  1923.   With WglrGrid
  1924.     If Val(Trim(.TextMatrix(sjh, Sjl))) = 0 Then
  1925.        .TextMatrix(sjh, Sjl) = ""
  1926.     End If
  1927.   End With
  1928. End Sub
  1929. Private Sub fhyxh()                                                     '返回录入数据有效行,同时让得到焦点网格可见
  1930.   With WglrGrid
  1931.    If .Row >= .FixedRows Then
  1932.       If .TextMatrix(.Row, 0) <> "*" Then
  1933.          For Rowjsq = .FixedRows To .Rows - 1
  1934.              If .TextMatrix(Rowjsq, 0) <> "*" Then
  1935.                 Exit For
  1936.              End If
  1937.          Next Rowjsq
  1938.          If Rowjsq <= .Rows - 1 Then
  1939.             changelock = True
  1940.               .Select Rowjsq, .Col
  1941.             changelock = False
  1942.          Else
  1943.             changelock = True
  1944.               .Select .Rows - 1, .Col
  1945.             changelock = False
  1946.          End If
  1947.       End If
  1948.       Call Xldqh
  1949.    End If
  1950.   End With
  1951. End Sub
  1952. Private Sub Xldqh()                                                      '显露当前行
  1953.   Dim Toprowte As Long
  1954.   With WglrGrid
  1955.     Toprowte = 0
  1956.     Do While .CellTop + .RowHeight(.Row) + Fzxwghs * Sjhgd > .Height And .TopRow <> Toprowte
  1957.        Toprowte = .TopRow
  1958.        .TopRow = .TopRow + 1
  1959.     Loop
  1960.     Toprowte = 0
  1961.     Do While .CellTop < .FixedRows * .RowHeight(0) And .TopRow <> Toprowte
  1962.        Toprowte = .TopRow
  1963.        .TopRow = .TopRow - 1
  1964.     Loop
  1965.   End With
  1966. End Sub
  1967. Private Sub Xldql()                                                     '显露当前列
  1968.  Dim Leftcolte As Long
  1969.  With WglrGrid
  1970.    If .Col >= Qslz Then
  1971.     If .LeftCol > .Col Then
  1972.        .LeftCol = .Col
  1973.     End If
  1974.     Leftcolte = 0
  1975.     Do While .CellLeft + .CellWidth > .Width And .LeftCol <> Leftcolte
  1976.        Leftcolte = .LeftCol
  1977.        .LeftCol = .LeftCol + 1
  1978.     Loop
  1979.   End If
  1980.  End With
  1981. End Sub
  1982. Private Function pdhwk(sjh As Long)                                     '判断网格行是否为空行(所有录入字段均为空*非录入字段除外)
  1983.  With WglrGrid
  1984.    For Coljsq = Qslz To .Cols - 1
  1985.        If Len(Trim(.TextMatrix(sjh, Coljsq))) <> 0 And GridBoolean(Coljsq, 1) Then
  1986.           pdhwk = False
  1987.           Exit Function
  1988.        End If
  1989.    Next Coljsq
  1990.    pdhwk = True
  1991.  End With
  1992. End Function
  1993. Private Sub Xyxhbz(sjh As Long)                                         '写行有效性标志,并判断是否增行
  1994.    With WglrGrid
  1995.     If .TextMatrix(sjh, 0) = "*" Then
  1996.        Exit Sub
  1997.     End If
  1998.     .TextMatrix(sjh, 0) = "*"
  1999.     If sjh >= .Rows - Fzxwghs - 1 Then
  2000.        .AddItem ""
  2001.        .RowHeight(.Rows - 1) = Sjhgd
  2002.     End If
  2003.    End With
  2004. End Sub
  2005. Private Sub GsToolbar_ButtonClick(ByVal Button As MSComctlLib.Button)   '表格格式设置(通用)
  2006.     Select Case Button.Key
  2007.       Case "bcgs"                              '保存表格格式
  2008.         Call Bcwggs(WglrGrid, GridCode)
  2009.       Case "hfmrgs"                            '恢复默认格式
  2010.         Call Hfmrgs(WglrGrid, GridCode)
  2011.     End Select
  2012. End Sub
  2013. Private Sub bbyl(bbylte As Boolean)                                     '打印预览(通用)
  2014.   Dim Bbzbt$, Bbxbt() As String, bbxbtzzxs() As Integer, Bbxbtgs As Integer
  2015.   Dim Bbbwh() As String, Bbbwhzzxs() As Integer, Bbbwhgs As Integer
  2016.   Bbxbtgs = 1                                  '报 表 小 标 题 行 数
  2017.   Bbbwhgs = 1                                  '报 表 表 尾 行 数
  2018.   ReDim Bbxbt(1 To Bbxbtgs)
  2019.   ReDim bbxbtzzxs(1 To Bbxbtgs)
  2020.   If Bbbwhgs <> 0 Then
  2021.      ReDim Bbbwh(1 To Bbbwhgs)
  2022.      ReDim Bbbwhzzxs(1 To Bbbwhgs)
  2023.   End If
  2024.   Bbzbt = ReportTitle
  2025.   
  2026.   Bbxbt(1) = Space(45) + Fun_FormatOutPut("制单日期:" + Trim(LrText(1).Text), 30)
  2027.   Bbxbt(1) = Bbxbt(1) + Fun_FormatOutPut("凭证字号:" + Trim(LrText(0).Text) + "-" + Trim(LrText(3).Text), 26)
  2028.   Bbbwh(1) = Fun_FormatOutPut("会计主管:", 18) + Fun_FormatOutPut("记帐:" + Lab_Book, 18)
  2029.   Bbbwh(1) = Bbbwh(1) + Fun_FormatOutPut("出纳:", 18) + Fun_FormatOutPut("审核:" + Lab_Checker, 18)
  2030.   Bbbwh(1) = Bbbwh(1) + Fun_FormatOutPut("制单:" + Lab_Bill, 18) + Trim(Fun_FormatOutPut("附单据数:" + Trim(LrText(2).Text), 23))
  2031.   
  2032.   bbxbtzzxs(1) = 0                             '报表行组织形式(0-居左 1-居中 2-居右)
  2033.   Bbbwhzzxs(1) = 1
  2034.   Call Sub_Scpzbb(WglrGrid)                    '生成报表数据(自定义程序)
  2035.   Call Scdybb(Dyymctbl, Bbzbt, Bbxbt(), bbxbtzzxs(), Bbxbtgs, Bbbwh(), Bbbwhzzxs(), Bbbwhgs, bbylte)
  2036.   If Not bbylte Then
  2037.      Unload DY_Tybbyldy
  2038.   End If
  2039. End Sub
  2041. '************以下为文本框录入处理程序(固定不变部分)*************'
  2043. Private Sub Wbklrwbcl(Index As Integer)    '文本框录入事后处理程序
  2045.   '以下为依据实际情况自定义部分[
  2046.   
  2047.       '在此填写文本框录入事后处理程序
  2048.    
  2049.   ']以上为依据实际情况自定义部分
  2050. End Sub
  2051. Private Sub LrText_Change(Index As Integer)
  2053.    '屏蔽程序改变控制
  2054.    If TextChangeLock Then
  2055.       Exit Sub
  2056.    End If
  2057.    
  2058.    TextValiJudgeLock(Index) = False    '打开有效性判断锁
  2059.     
  2060.     '限制字段录入长度
  2061.           
  2062.      TextChangeLock = True  '加锁(防止执行Lrtext_Change)
  2063.         Select Case Textint(Index, 1)
  2064.            Case 8           '金额型
  2065.              Call Sjgskz(LrText(Index), Xtjezws - Xtjexsws - 1, Xtjexsws)
  2066.            Case 9           '数量型
  2067.              Call Sjgskz(LrText(Index), Xtslzws - Xtslxsws - 1, Xtslxsws)
  2068.            Case 10          '单价型
  2069.              Call Sjgskz(LrText(Index), Xtdjzws - Xtdjxsws - 1, Xtdjxsws)
  2070.            Case Else        '其他小数类型控制
  2071.               If Textint(Index, 6) <> 0 Or Textint(Index, 7) <> 0 Then
  2072.                  Call Sjgskz(LrText(Index), Textint(Index, 6), Textint(Index, 7))
  2073.               End If
  2074.         End Select
  2075.         
  2076.         '[>>随时计算最新单据号
  2077.         If Index = 0 Then
  2078.            Call Sub_JsVouchNo
  2079.         End If
  2080.         '<<]
  2081.         
  2082.      TextChangeLock = False '解锁
  2083.      
  2084. End Sub
  2085. Private Sub LrText_GotFocus(Index As Integer)                                                 '文本框得到焦点,显示相应信息
  2086.    Call TextShow(Index)
  2087. End Sub
  2088. Private Sub LrText_KeyDown(Index As Integer, KeyCode As Integer, Shift As Integer)            '字段按F2键提供帮助
  2089.    Select Case KeyCode
  2090.       Case vbKeyF2
  2091.         Call Text_Help(Index)
  2092.    End Select
  2093. End Sub
  2094. Private Sub LrText_KeyPress(Index As Integer, KeyAscii As Integer)                            '文本框录入事中控制
  2095.    Call InputFieldLimit(LrText(Index), Textint(Index, 1), KeyAscii)
  2096. End Sub
  2097. Private Sub LrText_LostFocus(Index As Integer)                                                '文本框失去焦点进行有效性判断及相应处理
  2098.   If Textint(Index, 9) = 0 Or Textint(Index, 9) = 1 Then '事中判断
  2099.      Call TextYxxpd(Index)
  2100.   End If
  2101. End Sub
  2102. Private Sub Ydcommand1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
  2103.    Call Text_Help(Ydcommand1.Tag)
  2104. End Sub
  2105. Private Sub Text_Help(Index As Integer)                                                       '录入字段帮助
  2106.   If Not Ydcommand1.Visible Then
  2107.      Exit Sub
  2108.   End If
  2109.    TextValiLock = True
  2110.      Call Drbmhelp(Textint(Index, 2), Textstr(Index, 4), Trim(LrText(Index).Text))
  2111.      If Len(Xtfhcs) <> 0 Then
  2112.         If Textint(Index, 3) = 1 Then
  2113.            LrText(Index).Text = Xtfhcsfz
  2114.            LrText(Index).Tag = Xtfhcs
  2115.         Else
  2116.            LrText(Index).Text = Xtfhcs
  2117.            LrText(Index).Tag = Xtfhcsfz
  2118.         End If
  2119.        
  2120.      End If
  2121.    TextValiLock = False
  2122.    LrText(Index).SetFocus
  2123. End Sub
  2124. Private Sub TextShow(Index As Integer)        '文本框得到焦点,显示相应信息
  2125.     If Textboolean(Index, 1) Then
  2126.        Ydcommand1.Visible = True
  2127.        Ydcommand1.Move LrText(Index).Left + LrText(Index).Width, LrText(Index).Top
  2128.        Ydcommand1.Tag = Index
  2129.     Else
  2130.        Ydcommand1.Tag = ""
  2131.        Ydcommand1.Visible = False
  2132.     End If
  2133. End Sub
  2134. Private Sub Wbkcsh()                          '录入文本框初始化
  2135.   
  2136.   '最大录入文本框索引值
  2137.   Max_Text_Index = Textvar(1)
  2138.   
  2139.   ReDim TextValiJudgeLock(Max_Text_Index)
  2140.   For Jsqte = 0 To Max_Text_Index
  2141.      If Len(Trim(Textstr(Jsqte, 1))) <> 0 Then
  2142.         TextChangeLock = True
  2143.          LrText(Jsqte).Text = ""
  2144.          LrText(Jsqte).Tag = ""
  2145.          If Textint(Jsqte, 5) <> 0 Then
  2146.             LrText(Jsqte).MaxLength = Textint(Jsqte, 5)
  2147.          End If
  2148.         TextChangeLock = False
  2149.      End If
  2150.      TextValiJudgeLock(Jsqte) = True
  2151.   Next Jsqte
  2152. End Sub
  2153. Private Function TextYxxpd(Index As Integer) As Boolean           '文本框有效性判断
  2154.   Dim SQLSTR As String
  2155.   Dim Findrec As New ADODB.Recordset
  2156.   
  2157.   '按帮助不进行有效性判断
  2158.   
  2159.   If TextValiLock Then
  2160.      TextValiLock = False
  2161.      TextYxxpd = True
  2162.      Exit Function
  2163.   End If
  2164.   
  2165.   '文本框内容未曾改变不进行有效性判断
  2166.   
  2167.   If TextValiJudgeLock(Index) Then
  2168.      Ydcommand1.Visible = False
  2169.      TextYxxpd = True
  2170.      Exit Function
  2171.   End If
  2172.   If Trim(LrText(Index)) = "" Then
  2173.      LrText(Index).Tag = ""
  2174.      Call Wbklrwbcl(Index)
  2175.      Ydcommand1.Visible = False
  2176.      TextValiJudgeLock(Index) = True
  2177.      TextYxxpd = True
  2178.      
  2179.      '[>>如果凭证类别清空，则字号应清空
  2180.      If Index = 0 Then
  2181.       TextChangeLock = True
  2182.        LrText(3).Text = ""
  2183.       TextChangeLock = False
  2184.      End If
  2185.      '<<]
  2186.      
  2187.      Exit Function
  2188.   End If
  2189.        Select Case Textint(Index, 4)
  2190.          Case 1      '编码型
  2191.             SQLSTR = Trim(Textstr(Index, 5))
  2192.             SQLSTR = Replace(SQLSTR, "@", "'" + Trim(LrText(Index).Text) + "'")
  2193.             Set Findrec = Cw_DataEnvi.DataConnect.Execute(SQLSTR)
  2194.             If Findrec.EOF Then
  2195.                Call Xtxxts(Trim(Textstr(Index, 6)), 0, 1)
  2196.                LrText(Index).SetFocus
  2197.                Exit Function
  2198.             Else
  2199.                Select Case Textint(Index, 3)
  2200.                  Case 0
  2201.                    If Len(Trim(Textstr(Index, 2))) <> 0 Then
  2202.                       LrText(Index).Text = Trim(Findrec.Fields(Trim(Textstr(Index, 2))))
  2203.                    End If
  2204.                     If Len(Trim(Textstr(Index, 3) & "")) <> 0 Then
  2205.                       LrText(Index).Tag = Trim(Findrec.Fields(Trim(Textstr(Index, 3))))
  2206.                    End If
  2207.                  Case 1
  2208.                    If Len(Trim(Textstr(Index, 3) & "")) <> 0 Then
  2209.                       LrText(Index).Text = Trim(Findrec.Fields(Trim(Textstr(Index, 3))))
  2210.                    End If
  2211.                     If Len(Trim(Textstr(Index, 2))) <> 0 Then
  2212.                       LrText(Index).Tag = Trim(Findrec.Fields(Trim(Textstr(Index, 2))))
  2213.                    End If
  2214.                End Select
  2215.             End If
  2216.             
  2217.             '[>>凭证类别如有效,且内容已经发生改变则自动计算类别字号
  2218.              If Index = 0 Then
  2219.               Call Sub_JsVouchNo
  2220.              End If
  2221.              
  2222.             '<<]
  2223.             
  2224.          Case 2      '日期型
  2225.             If IsDate(LrText(Index).Text) Then
  2226.                LrText(Index).Text = Format(LrText(Index).Text, "yyyy-mm-dd")
  2227.              Else
  2228.                Tsxx = "非法公历日期!(格式:" + Format(Date, "yyyy-mm-dd") + ")"
  2229.                Call Xtxxts(Tsxx, 0, 1)
  2230.                LrText(Index).SetFocus
  2231.                Exit Function
  2232.             End If
  2233.          Case 3      '其他类型
  2234.        End Select
  2235.    Ydcommand1.Visible = False
  2236.    TextValiJudgeLock(Index) = True
  2237.    TextYxxpd = True
  2238. End Function