企业管理

开发平台：

Visual Basic

：源码内容

'计算合计数据(清零)
For Jsqte = Qslz To WglrGrid.Cols - 1
Call Sjhj(Jsqte)
Next Jsqte
'凭证类别得到焦点
LrText(0).SetFocus
'有错凭证标识隐藏
Lab_Error.Visible = False
End Sub
Private Sub Sub_EditBill() '修改一张单据
Dim RecTemp As New ADODB.Recordset '临时使用动态集
'判断用户是否有此功能执行权限,如有则写上机日志(进入)
If Not Security_Log(Str_RightEdit, Xtczybm, 1, True) Then
Exit Sub
End If
'判断当前凭证是否允许修改
If Not Fun_AllowEdit Then
Exit Sub
End If
'设置操作状态为修改
Lab_OperStatus.Caption = "3"
'设置工具条状态
Call Sub_OperStatus("30")
'显示制单人
Lab_Bill.Caption = Xtczy
End Sub
Private Sub Sub_DeleteBill() '删除当前单据
Dim YAnswer As Integer
'判断用户是否有此功能执行权限,如有则写上机日志(进入)
If Not Security_Log(Str_RightEdit, Xtczybm, 1, True) Then
Exit Sub
End If
'判断当前凭证是否允许删除
If Not Fun_AllowEdit Then
Exit Sub
End If
Tsxx = "请确认是否删除当前凭证?"
Yhanswer = Xtxxts(Tsxx, 2, 2)
If Yhanswer = 1 Then
'1.删除凭证所有内容
Cw_DataEnvi.DataConnect.Execute ("Delete Cwzz_AccVouchSub Where VouchID=" & Val(Lab_VouchId.Caption))
Cw_DataEnvi.DataConnect.Execute ("Delete Cwzz_AccVouchMain Where VouchID=" & Val(Lab_VouchId.Caption))
'add by 奚俊峰
Cw_DataEnvi.DataConnect.Execute ("Delete from Cwzz_CashFlowData Where VouchID=" & Val(Lab_VouchId.Caption))
Tsxx = "该凭证已被删除!"
Call Xtxxts(Tsxx, 0, 4)
Else
Exit Sub
End If
Select Case Trim(Lab_Pzclzt.Caption)
Case "1" '填制凭证
Call Sub_AddBill
'设置操作状态为浏览
Lab_OperStatus = "1"
Call Sub_OperStatus("10")
Case "2" '查询凭证
End Select
End Sub
Private Sub Sub_AbandonBill() '放弃对当前单据的操作
'先关闭录入载体
changelock = True
Valilock = True
Call Ycwbk
changelock = False
Valilock = False
Select Case Trim(Lab_OperStatus.Caption)
Case "2" '新增状态
Call Sub_AddBill
For Jsqte = Max_Text_Index To 0 Step -1
LrText(Jsqte).Text = ""
Next Jsqte
'设置操作状态为浏览
Lab_OperStatus = "1"
Call Sub_OperStatus("10")
Case "3" '修改状态
'重新显示当前单据
Call Sub_ShowBill
'设置操作状态为浏览
Lab_OperStatus = "1"
Call Sub_OperStatus("11")
End Select
End Sub
Private Sub Sub_QueryBill() '查询凭证
PZ_FrmPzcx.Show 1
If Xtfhcs = "1" Then
Call Sub_ShowBill
'设置操作状态为浏览
Lab_OperStatus.Caption = "1"
'设置工具条状态
Call Sub_OperStatus("11")
End If
End Sub
Private Sub Combo_Kjqj_Click() '会计期间发生变化则自动计算单据编号
Call Sub_JsVouchNo
End Sub
Private Sub Sub_JsVouchNo() '自动计算新增单据编号
Dim RecTemp As New ADODB.Recordset '临时使用动态集
'单据为新增时才有效
If Lab_OperStatus <> "2" Then
Exit Sub
End If
Sqlstr = "Select MAX(VouchNo) AS MVouchNo FROM Cwzz_AccVouchMain Where Year=" & Mid(Combo_Kjqj.Text, 1, 4) & " AND Period=" & Mid(Combo_Kjqj.Text, 6, 2) & _
" AND VouchClassCode='" & Trim(LrText(0).Text) & "'"
Set RecTemp = Cw_DataEnvi.DataConnect.Execute(Sqlstr)
TextChangeLock = True
If Not IsNull(RecTemp.Fields("MVouchNo")) Then
LrText(3).Text = Mid(Trim(Str(10000 + RecTemp.Fields("MVouchNo") + 1)), 2, 4)
Else
LrText(3).Text = "0001"
End If
TextChangeLock = False
End Sub
Private Function Sub_SaveBill() As Boolean '保存单据
Dim RecTemp As New ADODB.Recordset '临时使用动态集
Dim Recfind As New ADODB.Recordset '有效性判断动态集
Dim Rec_AccVouchMain As New ADODB.Recordset '凭证主表动态集
Dim Rec_AccVouch As New ADODB.Recordset '凭证子表动态集
Dim Rowjsq As Long '网格行计数器
Dim Coljsq As Long '网格列计数器
Dim Jsqte As Integer '临时计数器
Dim Int_RowCount As Integer '有效数据行计数器
Dim Bln_AssVali As Boolean '辅助核算错误标识
Dim Lrywlz As Long '录入有误列值
Dim Dbl_Jfhj As Double '借方合计
Dim Dbl_Dfhj As Double '贷方合计
Dim Int_Year As Integer '用户选择会计年度
Dim Int_Period As Integer '用户选择会计期间
Dim Int_VouchNo As Integer '单据号
For Jsqte = 0 To Max_Text_Index
If Textint(Jsqte, 8) = 1 Then '字段不能为空
If Len(Trim(LrText(Jsqte).Text)) = 0 Then
Tsxx = Textstr(Jsqte, 7) & "不能为空!"
Call Xtxxts(Tsxx, 0, 1)
LrText(Jsqte).SetFocus
Sub_SaveBill = False
Exit Function
End If
Else
If Textint(Jsqte, 8) = 2 Then '字段不能为零
If Val(Trim(LrText(Jsqte).Text)) = 0 Then
Tsxx = Textstr(Jsqte, 7) & "不能为零!"
Call Xtxxts(Tsxx, 0, 1)
LrText(Jsqte).SetFocus
Sub_SaveBill = False
Exit Function
End If
End If
End If
Next Jsqte
'对需要进行事后判断的文本框录入内容进行有效性判断 (固定不变)
For Jsqte = 0 To Max_Text_Index
If Textint(Jsqte, 9) = 0 Or Textint(Jsqte, 9) = 2 Then
If Not TextYxxpd(Jsqte) Then
Exit Function
End If
End If
Next Jsqte
'[判断用户所选会计期间是否有效(非结帐月份),且制单日期必须和所选会计期间一致
Sqlstr = "Select * FROM Gy_Kjrlb Where KjYear=" & Mid(Combo_Kjqj.Text, 1, 4) & " AND Period=" & Mid(Combo_Kjqj.Text, 6, 2)
Set RecTemp = Cw_DataEnvi.DataConnect.Execute(Sqlstr)
With RecTemp
If Not .EOF Then
If .Fields("Cwzzjzbz") Then
Tsxx = "所选会计期间已经结帐,不能再填制凭证!"
Call Xtxxts(Tsxx, 0, 1)
Combo_Kjqj.SetFocus
Exit Function
End If
If Not (CDate(LrText(1).Text) >= CDate(.Fields("Qsrq")) And CDate(LrText(1).Text) <= CDate(.Fields("Zzrq"))) Then
Tsxx = "制单日期应在所选会计期间范围内!"
Call Xtxxts(Tsxx, 0, 1)
LrText(1).SetFocus
Exit Function
End If
End If
End With
'下面将对所有有效数据行进行有效性判断
Int_RowCount = 0
Dbl_Jfhj = 0
Dbl_Dfhj = 0
With WglrGrid
For Rowjsq = .FixedRows To .Rows - 1
'带*号者为有效数据行
If .TextMatrix(Rowjsq, 0) <> "*" Then
Exit For
Else
Int_RowCount = Int_RowCount + 1
End If
'1.首先进行为空或为零判断(固定不变)
For Coljsq = Qslz To .Cols - 1
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
Tsxx = GridStr(Coljsq, 2)
Lrywlz = Coljsq
GoTo Lrcwcl
Exit For
End If
Next Coljsq
'2.[自定义判断(补丁)
If Val(Trim(.TextMatrix(Rowjsq, Sydz("004", GridStr(), Szzls)))) = 0 And Val(Trim(.TextMatrix(Rowjsq, Sydz("005", GridStr(), Szzls)))) = 0 Then
Tsxx = "借方和贷方金额不能同时为零!"
Lrywlz = Sydz("004", GridStr(), Szzls)
GoTo Lrcwcl
End If
If Val(Trim(.TextMatrix(Rowjsq, Sydz("004", GridStr(), Szzls)))) <> 0 And Val(Trim(.TextMatrix(Rowjsq, Sydz("005", GridStr(), Szzls)))) <> 0 Then
Tsxx = "借方和贷方金额不能同时不为零!"
Lrywlz = Sydz("004", GridStr(), Szzls)
GoTo Lrcwcl
End If
'判断辅助核算项目是否填写并是否有效
Sqlstr = "Select * FROM Cwzz_AccCode Where Ccode='" & Trim(.TextMatrix(Rowjsq, Sydz("002", GridStr(), Szzls))) & "'"
Set RecTemp = Cw_DataEnvi.DataConnect.Execute(Sqlstr)
With RecTemp
If .EOF Then
Tsxx = "此科目不存在!"
GoTo Lrcwcl
End If
If Not .Fields("EndFlag") Then
Tsxx = "此科目非末级科目!"
GoTo Lrcwcl
End If
If .Fields("StopFlag") Then
Tsxx = "此科目已停用"
GoTo Lrcwcl
End If
'对于银行科目,如结算方式不为空则结算方式必须有效
If Trim(RecTemp.Fields("Cproperty")) = "银行" And Len(Trim(WglrGrid.TextMatrix(Rowjsq, 1))) <> 0 Then
Set Recfind = Cw_DataEnvi.DataConnect.Execute("Select SSCode FROM Gy_Settlement Where SSCode='" & Trim(WglrGrid.TextMatrix(Rowjsq, 1)) & "'")
If Recfind.EOF Then
Tsxx = "此结算方式不存在!"
Lrywlz = Sydz("002", GridStr(), Szzls)
Bln_AssVali = True
GoTo Lrcwcl
End If
End If
'如有数量核算且用户选择数量不能为零则数量项不能为零
If RecTemp.Fields("QuantityFlag") And Chk_Quantity.Value = 1 And Val(WglrGrid.TextMatrix(Rowjsq, 5)) = 0 Then
Tsxx = "此科目需要数量核算,数量项不能为零"
Lrywlz = Sydz("002", GridStr(), Szzls)
Bln_AssVali = True
GoTo Lrcwcl
End If
'部门核算则部门不能为空且有效
If RecTemp.Fields("DeptFlag") And Len(Trim(WglrGrid.TextMatrix(Rowjsq, 12))) = 0 Then
Tsxx = "此科目需要部门核算,部门项不能为空"
Lrywlz = Sydz("002", GridStr(), Szzls)
Bln_AssVali = True
GoTo Lrcwcl
Else
If RecTemp.Fields("DeptFlag") And Len(Trim(WglrGrid.TextMatrix(Rowjsq, 12))) <> 0 Then
Set Recfind = Cw_DataEnvi.DataConnect.Execute("Select DeptCode FROM Gy_Department Where DeptCode='" & Trim(WglrGrid.TextMatrix(Rowjsq, 12)) & "'")
If Recfind.EOF Then
Tsxx = "此部门不存在!"
Lrywlz = Sydz("002", GridStr(), Szzls)
Bln_AssVali = True
GoTo Lrcwcl
End If
End If
End If
'往来单位核算则往来单位不能为空
If RecTemp.Fields("CusFlag") And Len(Trim(WglrGrid.TextMatrix(Rowjsq, 14))) = 0 Then
Tsxx = "此科目需要往来单位核算,往来单位项不能为空"
Lrywlz = Sydz("002", GridStr(), Szzls)
Bln_AssVali = True
GoTo Lrcwcl
Else
If RecTemp.Fields("CusFlag") And Len(Trim(WglrGrid.TextMatrix(Rowjsq, 14))) <> 0 Then
Set Recfind = Cw_DataEnvi.DataConnect.Execute("Select CusCode FROM Gy_Customer Where CusCode='" & Trim(WglrGrid.TextMatrix(Rowjsq, 14)) & "'")
If Recfind.EOF Then
Tsxx = "此往来单位不存在!"
Lrywlz = Sydz("002", GridStr(), Szzls)
Bln_AssVali = True
GoTo Lrcwcl
End If
End If
End If
'个人往来核算则个人项不能为空
If RecTemp.Fields("PersonFlag") And Len(Trim(WglrGrid.TextMatrix(Rowjsq, 16))) = 0 Then
Tsxx = "此科目需要个人往来核算,个人项不能为空"
Lrywlz = Sydz("002", GridStr(), Szzls)
Bln_AssVali = True
GoTo Lrcwcl
Else
If RecTemp.Fields("PersonFlag") And Len(Trim(WglrGrid.TextMatrix(Rowjsq, 16))) <> 0 Then
Set Recfind = Cw_DataEnvi.DataConnect.Execute("Select PersonCode FROM Gy_Person Where PersonCode='" & Trim(WglrGrid.TextMatrix(Rowjsq, 16)) & "'")
If Recfind.EOF Then
Tsxx = "此个人不存在!"
Lrywlz = Sydz("002", GridStr(), Szzls)
Bln_AssVali = True
GoTo Lrcwcl
End If
End If
End If
'项目核算则项目不能为空
If RecTemp.Fields("ItemFlag") And Len(Trim(WglrGrid.TextMatrix(Rowjsq, 20))) = 0 Then
Tsxx = "此科目需要项目核算,核算项目不能为空"
Lrywlz = Sydz("002", GridStr(), Szzls)
Bln_AssVali = True
GoTo Lrcwcl
Else
If RecTemp.Fields("ItemFlag") And Len(Trim(WglrGrid.TextMatrix(Rowjsq, 20))) <> 0 Then
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)) & "'")
If Recfind.EOF Then
Tsxx = "此核算项目不存在!"
Lrywlz = Sydz("002", GridStr(), Szzls)
Bln_AssVali = True
GoTo Lrcwcl
Else
If Recfind.Fields("QuantityFlag") And Val(WglrGrid.TextMatrix(Rowjsq, 22)) = 0 Then
Tsxx = "此项目需数量核算,则项目数量不能为零!"
Lrywlz = Sydz("002", GridStr(), Szzls)
Bln_AssVali = True
GoTo Lrcwcl
End If
End If
End If
End If
End With
'计算借贷方合计数据
Dbl_Jfhj = Dbl_Jfhj + Val(WglrGrid.TextMatrix(Rowjsq, Sydz("004", GridStr(), Szzls)))
Dbl_Dfhj = Dbl_Dfhj + Val(WglrGrid.TextMatrix(Rowjsq, Sydz("005", GridStr(), Szzls)))
Next Rowjsq
'会计分录行数不能为零
If Int_RowCount = 0 Then
Tsxx = "凭证会计分录行数为零,不能存盘!"
Call Xtxxts(Tsxx, 0, 1)
Exit Function
End If
'凭证借贷双方合计必须平衡
If Abs(Dbl_Jfhj - Dbl_Dfhj) >= 0.01 Then
Tsxx = "凭证借贷不平衡!"
Call Xtxxts(Tsxx, 0, 1)
Exit Function
End If
End With '网格
'如果以上有效性检查均顺利通过,则执行存盘动作
Int_Year = Val(Mid(Combo_Kjqj.Text, 1, 4))
Int_Period = Val(Mid(Combo_Kjqj.Text, 6, 2))
On Error GoTo Swcwcl
Cw_DataEnvi.DataConnect.BeginTrans
If Trim(Lab_OperStatus) = "2" Then
'新增凭证
'1.判断凭证号是否重复或大于最大凭证号,如是则取最大值+1为当前凭证号,否则以当前凭证号存盘
Sqlstr = "Select MAX(VouchNo)+1 AS MVouchNo FROM Cwzz_AccVouchMain Where Year=" & Mid(Combo_Kjqj.Text, 1, 4) & " AND Period=" & Mid(Combo_Kjqj.Text, 6, 2) & _
" AND VouchClassCode='" & Trim(LrText(0).Text) & "'"
Set Rec_AccVouch = Cw_DataEnvi.DataConnect.Execute(Sqlstr)
If Not IsNull(Rec_AccVouch.Fields("MVouchNo")) Then
If Val(LrText(3).Text) > Rec_AccVouch.Fields("MVouchNo") Then
Call Sub_JsVouchNo
End If
End If
Sqlstr = "Select VouchID From Cwzz_AccVouchMain Where Year=" & Int_Year & " and Period=" & Int_Period & " And VouchClassCode='" & Trim(LrText(0).Text) & "' And VouchNo=" & Val(LrText(3).Text)
Set Rec_AccVouch = Cw_DataEnvi.DataConnect.Execute(Sqlstr)
If Not Rec_AccVouch.EOF Then
Call Sub_JsVouchNo
End If
Int_VouchNo = Val(LrText(3).Text) '凭证号
'打开凭证主表动态集
If Rec_AccVouchMain.State = 1 Then Rec_AccVouchMain.Close
Rec_AccVouchMain.Open "Select * From Cwzz_AccVouchMain Where 1=2", Cw_DataEnvi.DataConnect, adOpenDynamic, adLockOptimistic
With Rec_AccVouchMain
.AddNew
.Fields("VouchID") = CreatBillID("0101")
.Fields("Year") = Int_Year '会计年度
.Fields("Period") = Int_Period '会计期间
.Fields("Ddate") = CDate(LrText(1).Text) '制单日期
.Fields("VouchClassCode") = Trim(LrText(0).Text) '凭证类别
.Fields("VouchNo") = Int_VouchNo '凭证号
.Fields("Doc") = Val(LrText(2).Text) '附单据数
.Fields("Bill") = Trim(Lab_Bill.Caption) '制单人
.Fields("CheckFlag") = 0 '审核标志置"0"
.Fields("BookFlag") = 0 '记帐标志置"0"
.Fields("VouchSource") = "手工录入"
.Update
Lab_VouchId.Caption = .Fields("VouchID")
End With
Else
'修改凭证
'1.删除原凭证子表中所有内容
Int_VouchNo = Val(LrText(3).Text) '凭证号
Cw_DataEnvi.DataConnect.Execute ("Delete Cwzz_AccVouchSub Where VouchID=" & Val(Lab_VouchId.Caption))
'打开凭证主表动态集
If Rec_AccVouchMain.State = 1 Then Rec_AccVouchMain.Close
Rec_AccVouchMain.Open "Select * From Cwzz_AccVouchMain Where VouchID=" & Val(Lab_VouchId.Caption), Cw_DataEnvi.DataConnect, adOpenDynamic, adLockOptimistic
With Rec_AccVouchMain
.Fields("Year") = Int_Year '会计年度
.Fields("Period") = Int_Period '会计期间
.Fields("Ddate") = CDate(LrText(1).Text) '制单日期
.Fields("VouchClassCode") = Trim(LrText(0).Text) '凭证类别
.Fields("VouchNo") = Int_VouchNo '凭证号
.Fields("Doc") = Val(LrText(2).Text) '附单据数
.Fields("Bill") = Trim(Lab_Bill.Caption) '制单人
.Fields("CheckFlag") = 0 '审核标志置"0"
.Fields("BookFlag") = 0 '记帐标志置"0"
.Update
End With
End If
'打开凭证子表动态集
If Rec_AccVouch.State = 1 Then Rec_AccVouch.Close
Rec_AccVouch.Open "Select * From Cwzz_AccVouchSub Where 1=2", Cw_DataEnvi.DataConnect, adOpenDynamic, adLockOptimistic
For Rowjsq = WglrGrid.FixedRows To WglrGrid.Rows - 1
If WglrGrid.TextMatrix(Rowjsq, 0) <> "*" Then
Exit For
End If
With Rec_AccVouch
.AddNew
.Fields("SerialID") = Rowjsq
.Fields("VouchID") = Val(Lab_VouchId.Caption) '凭证ID
.Fields("Digest") = Trim(WglrGrid.TextMatrix(Rowjsq, Sydz("001", GridStr(), Szzls))) '摘要
.Fields("Ccode") = Trim(WglrGrid.TextMatrix(Rowjsq, Sydz("002", GridStr(), Szzls))) '会计科目
.Fields("Jfje") = Val(WglrGrid.TextMatrix(Rowjsq, Sydz("004", GridStr(), Szzls))) '借方金额
.Fields("Dfje") = Val(WglrGrid.TextMatrix(Rowjsq, Sydz("005", GridStr(), Szzls))) '贷方金额
If Val(WglrGrid.TextMatrix(Rowjsq, Sydz("004", GridStr(), Szzls))) <> 0 Then
.Fields("Jfsl") = Val(WglrGrid.TextMatrix(Rowjsq, 5)) '借方数量
Else
.Fields("Dfsl") = Val(WglrGrid.TextMatrix(Rowjsq, 5)) '贷方数量
End If
'如为外币核算则原币编码为外币编码否则填充本位币编码,同时填充原币金额
If Len(Trim(WglrGrid.TextMatrix(Rowjsq, 8))) <> 0 And Trim(WglrGrid.TextMatrix(Rowjsq, 8)) <> XtSCurrCode Then
.Fields("ForeignCurrCode") = Trim(WglrGrid.TextMatrix(Rowjsq, 8)) '外币编码
.Fields("AccRate") = Val(WglrGrid.TextMatrix(Rowjsq, 11)) '记帐汇率
If Val(WglrGrid.TextMatrix(Rowjsq, Sydz("004", GridStr(), Szzls))) <> 0 Then
.Fields("Wbjfje") = Val(WglrGrid.TextMatrix(Rowjsq, 10)) '外币借方金额
Else
.Fields("Wbdfje") = Val(WglrGrid.TextMatrix(Rowjsq, 10)) '外币贷方金额
End If
Else
.Fields("ForeignCurrCode") = XtSCurrCode '原币编码
.Fields("AccRate") = 1 '记帐汇率
If Val(WglrGrid.TextMatrix(Rowjsq, Sydz("004", GridStr(), Szzls))) <> 0 Then
.Fields("Wbjfje") = Val(WglrGrid.TextMatrix(Rowjsq, Sydz("004", GridStr(), Szzls))) '原币借方金额
Else
.Fields("Wbdfje") = Val(WglrGrid.TextMatrix(Rowjsq, Sydz("005", GridStr(), Szzls))) '原币贷方金额
End If
End If
If Len(Trim(WglrGrid.TextMatrix(Rowjsq, 4))) <> 0 Then
.Fields("BillDate") = CDate(Trim(WglrGrid.TextMatrix(Rowjsq, 4))) '发生日期(银行)
End If
If Len(Trim(WglrGrid.TextMatrix(Rowjsq, 1))) <> 0 Then
.Fields("SScode") = Trim(WglrGrid.TextMatrix(Rowjsq, 1)) '结算方式(银行)
End If
If Len(Trim(WglrGrid.TextMatrix(Rowjsq, 3))) <> 0 Then
.Fields("BillNo") = Trim(WglrGrid.TextMatrix(Rowjsq, 3)) '票号(银行)
End If
.Fields("BCheckFlag") = 0 '银行核对标志置0
.Fields("BDelete") = 0 '银行帐核销标志置0
If Len(Trim(WglrGrid.TextMatrix(Rowjsq, 16))) <> 0 Then
.Fields("PersonCode") = Trim(WglrGrid.TextMatrix(Rowjsq, 16)) '职员编码
End If
If Len(Trim(WglrGrid.TextMatrix(Rowjsq, 12))) <> 0 Then
.Fields("DeptCode") = Trim(WglrGrid.TextMatrix(Rowjsq, 12)) '部门编码
End If
If Len(Trim(WglrGrid.TextMatrix(Rowjsq, 14))) <> 0 Then
.Fields("CusCode") = Trim(WglrGrid.TextMatrix(Rowjsq, 14)) '往来客户编码
End If
If Len(Trim(WglrGrid.TextMatrix(Rowjsq, 25))) <> 0 Then
.Fields("SupplierCode") = Trim(WglrGrid.TextMatrix(Rowjsq, 25)) '往来供应商编码
End If
If Len(Trim(WglrGrid.TextMatrix(Rowjsq, 18))) <> 0 Then
.Fields("ItemClassCode") = Trim(WglrGrid.TextMatrix(Rowjsq, 18)) '项目大类编码
End If
If Len(Trim(WglrGrid.TextMatrix(Rowjsq, 20))) <> 0 Then
.Fields("ItemCode") = Trim(WglrGrid.TextMatrix(Rowjsq, 20)) '项目编码
If Val(WglrGrid.TextMatrix(Rowjsq, Sydz("004", GridStr(), Szzls))) <> 0 Then
.Fields("ItemJfsl") = Val(WglrGrid.TextMatrix(Rowjsq, 22)) '项目借方数量
Else
.Fields("ItemDfsl") = Val(WglrGrid.TextMatrix(Rowjsq, 22)) '项目贷方数量
End If
End If
If Len(Trim(WglrGrid.TextMatrix(Rowjsq, 24))) <> 0 Then
.Fields("TranPerson") = Trim(WglrGrid.TextMatrix(Rowjsq, 24)) '经办人
End If
.Update
End With
Next Rowjsq
Cw_DataEnvi.DataConnect.CommitTrans
Sub_SaveBill = True
Tsxx = "凭证存盘完毕! 凭证号:" & Trim(LrText(0).Text) & "--" & Trim(LrText(3).Text)
Call Xtxxts(Tsxx, 0, 4)
'标识单据发生改动
Bln_BillChange = True
If Chk_Xjll.Value = 1 Then '凭证存盘后是否马上进行现金流量分配
If Sf_CashFlow = True Then '判断该凭证是否有必要进行现金流量分配
Call Fp_Xjll '分配现金流量
End If
End If
'设置操作状态为浏览
Lab_OperStatus = "1"
Call Sub_OperStatus("11")
Exit Function
Swcwcl:
Cw_DataEnvi.DataConnect.RollbackTrans
Tsxx = "存盘过程中出现未知错误,程序自动恢复保存前状态!"
Call Xtxxts(Tsxx, 0, 1)
Exit Function
Lrcwcl: '录入错误处理
With WglrGrid
Call Xtxxts("(第 " + Trim(Str(Int_RowCount)) + " 条会计分录)-" + Tsxx, 0, 1)
changelock = True
.Select Rowjsq, Lrywlz
WglrGrid.SetFocus
changelock = False
Exit Function
End With
End Function
Private Sub Chk_DeleteMess_Click() '删行是否提示(点击)
If Chk_DeleteMess.Value = 1 Then
Shsfts = True
Else
Shsfts = False
End If
End Sub
Private Sub Sub_Option() '调用填制凭证选项
With PZ_FrmOption
'删行是否提示
.Chk_DeleteMess.Value = Me.Chk_DeleteMess.Value
'科目数量核算数量项是否可以为零
.Chk_Quantity.Value = Me.Chk_Quantity.Value
'打印凭证是否输出科目编码
.Chk_CodeOutput.Value = Me.Chk_CodeOutput.Value
'审核凭证时是否自动跳到下张
.Chk_CheckNext.Value = Me.Chk_CheckNext.Value
'汇总打印
.Chk_SumPrint.Value = Me.Chk_SumPrint.Value
.Show 1
End With
End Sub
'审核,弃审,标错,全审,全弃
Private Sub Sub_CheckBill() '审核
'判断用户是否有此功能执行权限,如有则写上机日志(进入)
If Not Security_Log(Str_RightCheck, Xtczybm, 1, True) Then
Exit Sub
End If
'已审核凭证不需要再次审核
If Trim(Lab_Checker.Caption) <> "" Then
Tsxx = "已审核凭证不需要再次审核!"
Call Xtxxts(Tsxx, 0, 4)
Exit Sub
End If
'标错凭证不能审核通过
If Lab_Error.Visible Then
Tsxx = "标错凭证不能审核通过!"
Call Xtxxts(Tsxx, 0, 4)
Exit Sub
End If
'将凭证写入审核标识
Cw_DataEnvi.DataConnect.Execute ("Update Cwzz_AccVouchMain Set CheckFlag=1,Checker='" & Xtczy & "' Where VouchID=" & Val(Lab_VouchId.Caption))
'写入系统操作员
Lab_Checker.Caption = Xtczy
'自动调入下一张凭证
If Chk_CheckNext.Value = 1 Then
Call Sub_next
End If
'标识单据发生变化
Bln_BillChange = True
End Sub
Private Sub Sub_AbandonCheck() '弃审
'判断用户是否有此功能执行权限,如有则写上机日志(进入)
If Not Security_Log(Str_RightCheck, Xtczybm, 1, True) Then
Exit Sub
End If
If Trim(Lab_Book.Caption) <> "" Then
Tsxx = "已记帐凭证不能弃审!"
Call Xtxxts(Tsxx, 0, 4)
Exit Sub
End If
If Trim(Lab_Checker.Caption) = "" Then
Tsxx = "未审核凭证不需要弃审!"
Call Xtxxts(Tsxx, 0, 4)
Exit Sub
End If
'写入系统操作员
Lab_Checker.Caption = ""
'将凭证去掉审核标识
Cw_DataEnvi.DataConnect.Execute ("Update Cwzz_AccVouchMain Set CheckFlag=0,Checker='' Where VouchID=" & Val(Lab_VouchId.Caption))
'自动调入下一张凭证
If Chk_CheckNext.Value = 1 Then
Call Sub_next
End If
'标识单据发生变化
Bln_BillChange = True
End Sub
Private Sub Sub_ErrorBill() '标错(如果凭证有错则去掉错误标识,如无错则写入错误标识)
'判断用户是否有此功能执行权限,如有则写上机日志(进入)
If Not Security_Log(Str_RightCheck, Xtczybm, 1, True) Then
Exit Sub
End If
If Lab_Error.Visible Then
'去掉凭证有错标识
Lab_Error.Visible = False
'将凭证去掉错误标识
Cw_DataEnvi.DataConnect.Execute ("Update Cwzz_AccVouchMain Set ErrorFlag=0 Where VouchID=" & Val(Lab_VouchId.Caption))
Else
If Trim(Lab_Checker.Caption) <> "" Then
Tsxx = "已审核凭证不能标错!"
Call Xtxxts(Tsxx, 0, 4)
Exit Sub
End If
'显示凭证有错标识
Lab_Error.Visible = True
'将凭证写入错误标识
Cw_DataEnvi.DataConnect.Execute ("Update Cwzz_AccVouchMain Set ErrorFlag=1 Where VouchID=" & Val(Lab_VouchId.Caption))
End If
'标识单据发生变化
Bln_BillChange = True
End Sub
Private Sub Sub_CheckAllBill() '全部审核
Dim Yhanswer As Integer
'判断用户是否有此功能执行权限,如有则写上机日志(进入)
If Not Security_Log(Str_RightCheck, Xtczybm, 1, True) Then
Exit Sub
End If
Tsxx = "请确认是否将所有查询凭证中" + Chr(10) + Chr(10) + "未复核凭证全部复核(标错凭证除外)?"
Yhanswer = Xtxxts(Tsxx, 2, 2)
If Yhanswer = 2 Then
Exit Sub
End If
With PZ_FrmPzcxjg
For Jsqte = .CxbbGrid.FixedRows To .CxbbGrid.Rows - 1
If .CxbbGrid.Cell(flexcpBackColor, Jsqte) = .Lab_Color(0).BackColor Then
'将凭证写入审核标识
Cw_DataEnvi.DataConnect.Execute ("Update Cwzz_AccVouchMain Set CheckFlag=1,Checker='" & Xtczy & "' Where ErrorFlag=0 And CheckFlag=0 and VouchID=" & Val(.CxbbGrid.TextMatrix(Jsqte, 0)))
End If
Next Jsqte
End With
If Not Lab_Error.Visible Then
'写入系统操作员
Lab_Checker.Caption = Xtczy
End If
Tsxx = "全部审核完毕!"
Call Xtxxts(Tsxx, 0, 4)
'标识单据发生变化
Bln_BillChange = True
End Sub
Private Sub Sub_AbandonAllCheck() '全部弃审
Dim Yhanswer As Integer
'判断用户是否有此功能执行权限,如有则写上机日志(进入)
If Not Security_Log(Str_RightCheck, Xtczybm, 1, True) Then
Exit Sub
End If
Tsxx = "请确认是否将所有查询凭证中" + Chr(10) + Chr(10) + "已复核凭证全部弃审(记帐凭证除外)?"
Yhanswer = Xtxxts(Tsxx, 2, 2)
If Yhanswer = 2 Then
Exit Sub
End If
Lab_Checker.Caption = ""
With PZ_FrmPzcxjg
For Jsqte = .CxbbGrid.FixedRows To .CxbbGrid.Rows - 1
If .CxbbGrid.Cell(flexcpBackColor, Jsqte) = .Lab_Color(0).BackColor Then
'将凭证写入审核标识
Cw_DataEnvi.DataConnect.Execute ("Update Cwzz_AccVouchMain Set CheckFlag=0,Checker='' Where BookFlag=0 And CheckFlag=1 and VouchID=" & Val(.CxbbGrid.TextMatrix(Jsqte, 0)))
End If
Next Jsqte
End With
Tsxx = "符合弃审条件的凭证已弃审完毕!"
Call Xtxxts(Tsxx, 0, 4)
'标识单据发生变化
Bln_BillChange = True
End Sub
'选择首张,上张,下张,末张
Private Sub Sub_First() '首张
With PZ_FrmPzcxjg
.CxbbGrid.Select .CxbbGrid.FixedRows, 0
If Val(Lab_VouchId.Caption) = Val(.CxbbGrid.TextMatrix(.CxbbGrid.Row, 0)) Then
Exit Sub
End If
Call Sub_ShowFindBill
End With
End Sub
Private Sub Sub_Prev() '上张
With PZ_FrmPzcxjg
Do While .CxbbGrid.Row > .CxbbGrid.FixedRows And Val(Lab_VouchId.Caption) = Val(.CxbbGrid.TextMatrix(.CxbbGrid.Row, 0))
.CxbbGrid.Row = .CxbbGrid.Row - 1
Loop
If Val(Lab_VouchId.Caption) = Val(.CxbbGrid.TextMatrix(.CxbbGrid.Row, 0)) Then
Exit Sub
End If
Call Sub_ShowFindBill
End With
End Sub
Private Sub Sub_next() '下张
With PZ_FrmPzcxjg
Do While .CxbbGrid.Row < .CxbbGrid.Rows - 1 And Val(Lab_VouchId.Caption) = Val(.CxbbGrid.TextMatrix(.CxbbGrid.Row, 0))
.CxbbGrid.Row = .CxbbGrid.Row + 1
Loop
If Val(Lab_VouchId.Caption) = Val(.CxbbGrid.TextMatrix(.CxbbGrid.Row, 0)) Then
Exit Sub
End If
Call Sub_ShowFindBill
End With
End Sub
Private Sub Sub_Last() '末张
With PZ_FrmPzcxjg
.CxbbGrid.Select .CxbbGrid.Rows - 1, 0
If Val(Lab_VouchId.Caption) = Val(.CxbbGrid.TextMatrix(.CxbbGrid.Row, 0)) Then
Exit Sub
End If
Call Sub_ShowFindBill
End With
End Sub
Private Sub Sub_ShowFindBill() '显示用户在单据列表中查询定位单据
With PZ_FrmPzcxjg
'填充查询凭证标识
Lab_VouchId.Caption = Val(.CxbbGrid.TextMatrix(.CxbbGrid.Row, 0))
Call Sub_ShowBill
End With
End Sub
Private Function Fun_AllowEdit() As Boolean '判断当前凭证是否允许编辑或删除
Dim RecTemp As New ADODB.Recordset '临时使用动态集
Sqlstr = "Select CheckFlag,BookFlag,Checker,Book From Cwzz_AccVouchMain Where VouchID=" & Val(Lab_VouchId.Caption)
Set RecTemp = Cw_DataEnvi.DataConnect.Execute(Sqlstr)
With RecTemp
If Not .EOF Then
If .Fields("CheckFlag") Or .Fields("BookFlag") Then
Tsxx = "该凭证已审核或记帐,不允许修改或删除!"
Call Xtxxts(Tsxx, 0, 4)
Lab_Checker = Trim(.Fields("Checker") & "")
Lab_Book = Trim(.Fields("Book") & "")
Exit Function
End If
End If
End With
Fun_AllowEdit = True
End Function
Public Sub Sub_Scpzbb(Cxsjwg As VSFlexGrid) '生成预览凭证报表
'过程参数:输出数据网格
Dim Yxhzjsq%, Yxlzjsq% '有效列值计数器,有效行值计数器
Dim Rowjsq As Long '临时行计数器
Dim Sjhjsq As Long '数据行计数器
Dim Int_Pzmyhs As Integer '凭证每页数据行数
Dim Dbl_Jfhj As Double '借方合计
Dim Dbl_Dfhj As Double '贷方合计
Dim CodeRs As New ADODB.Recordset '会计科目记录集，用以确定是否进行汇总打印，及汇总打印的科目代码和名称
Dim strCode As String '科目代码
Dim strCodeName As String '科目名称
Dim Dbl_Jfje As Double '借方金额
Dim Dbl_Dfje As Double '贷方金额
Dim I As Integer '循环变量
Dim Lng_FindRow As Long '汇总科目所在行
'生成有效数据表
With DY_Tybbyldy.DyylGrid
.FontName = Cxsjwg.FontName
.FontSize = Cxsjwg.FontSize
.FixedRows = Cxsjwg.FixedRows
.MergeCells = flexMergeFixedOnly
For Jsqte = 0 To .FixedRows - 1
.MergeRow(Jsqte) = True
Next Jsqte
.WordWrap = True
'重置数据列
Yxlzjsq = 4
.Cols = Yxlzjsq
.ColAlignment(2) = Cxsjwg.ColAlignment(Sydz("004", GridStr(), Szzls))
.ColAlignment(3) = Cxsjwg.ColAlignment(Sydz("005", GridStr(), Szzls))
.ColWidth(0) = Cxsjwg.ColWidth(Sydz("001", GridStr(), Szzls))
.ColWidth(1) = Cxsjwg.ColWidth(Sydz("002", GridStr(), Szzls)) + Cxsjwg.ColWidth(Sydz("003", GridStr(), Szzls))
.ColWidth(2) = Cxsjwg.ColWidth(Sydz("004", GridStr(), Szzls))
.ColWidth(3) = Cxsjwg.ColWidth(Sydz("005", GridStr(), Szzls))
.ColFormat(2) = Cxsjwg.ColFormat(Sydz("004", GridStr(), Szzls))
.ColFormat(3) = Cxsjwg.ColFormat(Sydz("005", GridStr(), Szzls))
For Yxlzjsq = 0 To 3
.MergeCol(Yxlzjsq) = True
Next Yxlzjsq
'设置标题行
.Rows = Cxsjwg.FixedRows
.TextMatrix(0, 0) = Cxsjwg.TextMatrix(0, Sydz("001", GridStr(), Szzls))
.TextMatrix(0, 1) = "科目名称"
.TextMatrix(0, 2) = Cxsjwg.TextMatrix(0, Sydz("004", GridStr(), Szzls))
.TextMatrix(0, 3) = Cxsjwg.TextMatrix(0, Sydz("005", GridStr(), Szzls))
.RowHeight(0) = Cxsjwg.RowHeight(0)
DY_Tybbyldy.DyylGrid.Cols = DY_Tybbyldy.DyylGrid.Cols + 1 '填加一辅助列保存汇总科目编码
For Rowjsq = Cxsjwg.FixedRows To Cxsjwg.Rows - 1
If (Not Cxsjwg.RowHidden(Rowjsq)) And (Not GridRowEmpty(Cxsjwg, Rowjsq)) Then
'判断本张凭证是否汇总打印,如汇总打印则在目标网格中查找汇总科目,如存在则累加,否则增加一新行
If Chk_SumPrint.Value = 1 Then
strCode = Cxsjwg.TextMatrix(Rowjsq, Sydz("002", GridStr(), Szzls)) '科目代码
Set CodeRs = Cw_DataEnvi.DataConnect.Execute("SELECT cCode,cName,cSumCode,iIfSum FROM Cwzz_AccCode WHERE cCode='" & strCode & "'")
If CodeRs!iIfSum = True And Trim(CodeRs!cSumCode & "") <> "" Then '如果汇总打印，成立条件为““汇总打印标识”为TRUE，且“汇总科目代码”不为空
strCode = Trim(CodeRs!cSumCode) '汇总打印代码
Set CodeRs = Cw_DataEnvi.DataConnect.Execute("SELECT cName FROM Cwzz_AccCode WHERE cCode='" & strCode & "'")
strCodeName = Trim(CodeRs!cname) '汇总科目名称
Dbl_Jfje = Val(Cxsjwg.TextMatrix(Rowjsq, Sydz("004", GridStr(), Szzls))) '借方金额
Dbl_Dfje = Val(Cxsjwg.TextMatrix(Rowjsq, Sydz("005", GridStr(), Szzls))) '贷方金额
Lng_FindRow = .FindRow(strCode, , .Cols - 1)
If Lng_FindRow <> -1 Then
'借
If Val(.TextMatrix(Lng_FindRow, 2)) + Dbl_Jfje <> 0 Then
.TextMatrix(Lng_FindRow, 2) = Val(.TextMatrix(Lng_FindRow, 2)) + Dbl_Jfje
Else
.TextMatrix(Lng_FindRow, 2) = ""
End If
'贷
If Val(.TextMatrix(Lng_FindRow, 3)) + Dbl_Dfje <> 0 Then
.TextMatrix(Lng_FindRow, 3) = Val(.TextMatrix(Lng_FindRow, 3)) + Dbl_Dfje
Else
.TextMatrix(Lng_FindRow, 3) = ""
End If
Else
.AddItem ""
.RowHeight(.Rows - 1) = Cxsjwg.RowHeight(Rowjsq)
'摘要
.TextMatrix(.Rows - 1, 0) = Cxsjwg.TextMatrix(Rowjsq, Sydz("001", GridStr(), Szzls))
'输出科目名称
If Chk_CodeOutput.Value = 1 Then
.TextMatrix(.Rows - 1, 1) = strCode + " " + strCodeName
Else
.TextMatrix(.Rows - 1, 1) = strCodeName
End If
.TextMatrix(.Rows - 1, .Cols - 1) = strCode
'借
If Dbl_Jfje <> 0 Then
.TextMatrix(.Rows - 1, 2) = Dbl_Jfje
Else
.TextMatrix(.Rows - 1, 2) = ""
End If
'贷
If Dbl_Dfje <> 0 Then
.TextMatrix(.Rows - 1, 3) = Dbl_Dfje
Else
.TextMatrix(.Rows - 1, 3) = ""
End If
End If '汇总输出完毕
Else
.AddItem ""
.RowHeight(.Rows - 1) = Cxsjwg.RowHeight(Rowjsq)
'摘要
.TextMatrix(.Rows - 1, 0) = Cxsjwg.TextMatrix(Rowjsq, Sydz("001", GridStr(), Szzls))
'输出科目名称
If Chk_CodeOutput.Value = 1 Then
.TextMatrix(.Rows - 1, 1) = Cxsjwg.TextMatrix(Rowjsq, Sydz("002", GridStr(), Szzls)) + " " + Cxsjwg.TextMatrix(Rowjsq, Sydz("003", GridStr(), Szzls))
Else
.TextMatrix(.Rows - 1, 1) = Cxsjwg.TextMatrix(Rowjsq, Sydz("003", GridStr(), Szzls))
End If
If Trim(Cxsjwg.TextMatrix(Rowjsq, 2)) <> "" Then '结算方式
.TextMatrix(.Rows - 1, 1) = .TextMatrix(.Rows - 1, 1) + Space(2) + Trim(Cxsjwg.TextMatrix(Rowjsq, 2))
End If
If Trim(Cxsjwg.TextMatrix(Rowjsq, 3)) <> "" Then '票号
.TextMatrix(.Rows - 1, 1) = .TextMatrix(.Rows - 1, 1) + Space(2) + Trim(Cxsjwg.TextMatrix(Rowjsq, 3))
End If
If Trim(Cxsjwg.TextMatrix(Rowjsq, 4)) <> "" Then '发生日期
.TextMatrix(.Rows - 1, 1) = .TextMatrix(.Rows - 1, 1) + Space(2) + Trim(Cxsjwg.TextMatrix(Rowjsq, 4))
End If
If Val(Cxsjwg.TextMatrix(Rowjsq, 5)) <> 0 Then '数量
.TextMatrix(.Rows - 1, 1) = .TextMatrix(.Rows - 1, 1) + Space(2) + Trim(Cxsjwg.TextMatrix(Rowjsq, 5)) + Trim(Cxsjwg.TextMatrix(Rowjsq, 7))
End If
If Trim(Cxsjwg.TextMatrix(Rowjsq, 9)) <> "" Then '外币名称
.TextMatrix(.Rows - 1, 1) = .TextMatrix(.Rows - 1, 1) + Space(2) + Trim(Cxsjwg.TextMatrix(Rowjsq, 10)) + Trim(Cxsjwg.TextMatrix(Rowjsq, 9))
End If
If Val(Cxsjwg.TextMatrix(Rowjsq, 11)) <> 0 Then '记帐汇率
.TextMatrix(.Rows - 1, 1) = .TextMatrix(.Rows - 1, 1) + Space(2) + "汇率:" + Trim(Cxsjwg.TextMatrix(Rowjsq, 11))
End If
If Trim(Cxsjwg.TextMatrix(Rowjsq, 13)) <> "" Then '部门
.TextMatrix(.Rows - 1, 1) = .TextMatrix(.Rows - 1, 1) + Space(2) + Trim(Cxsjwg.TextMatrix(Rowjsq, 13))
End If
If Trim(Cxsjwg.TextMatrix(Rowjsq, 15)) <> "" Then '往来客户
.TextMatrix(.Rows - 1, 1) = .TextMatrix(.Rows - 1, 1) + Space(2) + Trim(Cxsjwg.TextMatrix(Rowjsq, 15))
End If
If Trim(Cxsjwg.TextMatrix(Rowjsq, 26)) <> "" Then '往来供应商
.TextMatrix(.Rows - 1, 1) = .TextMatrix(.Rows - 1, 1) + Space(2) + Trim(Cxsjwg.TextMatrix(Rowjsq, 26))
End If
If Trim(Cxsjwg.TextMatrix(Rowjsq, 17)) <> "" Then '职员
.TextMatrix(.Rows - 1, 1) = .TextMatrix(.Rows - 1, 1) + Space(2) + Trim(Cxsjwg.TextMatrix(Rowjsq, 17))
End If
If Trim(Cxsjwg.TextMatrix(Rowjsq, 19)) <> "" Then '项目大类
.TextMatrix(.Rows - 1, 1) = .TextMatrix(.Rows - 1, 1) + Space(2) + Trim(Cxsjwg.TextMatrix(Rowjsq, 19))
End If
If Trim(Cxsjwg.TextMatrix(Rowjsq, 21)) <> "" Then '项目名称
.TextMatrix(.Rows - 1, 1) = .TextMatrix(.Rows - 1, 1) + Space(2) + Trim(Cxsjwg.TextMatrix(Rowjsq, 21))
End If
If Val(Cxsjwg.TextMatrix(Rowjsq, 22)) <> 0 Then '项目数量单位
.TextMatrix(.Rows - 1, 1) = .TextMatrix(.Rows - 1, 1) + Space(2) + Trim(Cxsjwg.TextMatrix(Rowjsq, 22)) + Trim(Cxsjwg.TextMatrix(Rowjsq, 23))
End If
If Trim(Cxsjwg.TextMatrix(Rowjsq, 24)) <> "" Then '经办人
.TextMatrix(.Rows - 1, 1) = .TextMatrix(.Rows - 1, 1) + Space(2) + "经办人:" + Trim(Cxsjwg.TextMatrix(Rowjsq, 24))
End If
'借方金额
.TextMatrix(.Rows - 1, 2) = Cxsjwg.TextMatrix(Rowjsq, Sydz("004", GridStr(), Szzls))
'贷方金额
.TextMatrix(.Rows - 1, 3) = Cxsjwg.TextMatrix(Rowjsq, Sydz("005", GridStr(), Szzls))
End If '凭证汇总输出
Else
.AddItem ""
.RowHeight(.Rows - 1) = Cxsjwg.RowHeight(Rowjsq)
'摘要
.TextMatrix(.Rows - 1, 0) = Cxsjwg.TextMatrix(Rowjsq, Sydz("001", GridStr(), Szzls))
'输出科目名称
If Chk_CodeOutput.Value = 1 Then
.TextMatrix(.Rows - 1, 1) = Cxsjwg.TextMatrix(Rowjsq, Sydz("002", GridStr(), Szzls)) + " " + Cxsjwg.TextMatrix(Rowjsq, Sydz("003", GridStr(), Szzls))
Else
.TextMatrix(.Rows - 1, 1) = Cxsjwg.TextMatrix(Rowjsq, Sydz("003", GridStr(), Szzls))
End If
If Trim(Cxsjwg.TextMatrix(Rowjsq, 2)) <> "" Then '结算方式
.TextMatrix(.Rows - 1, 1) = .TextMatrix(.Rows - 1, 1) + Space(2) + Trim(Cxsjwg.TextMatrix(Rowjsq, 2))
End If
If Trim(Cxsjwg.TextMatrix(Rowjsq, 3)) <> "" Then '票号
.TextMatrix(.Rows - 1, 1) = .TextMatrix(.Rows - 1, 1) + Space(2) + Trim(Cxsjwg.TextMatrix(Rowjsq, 3))
End If
If Trim(Cxsjwg.TextMatrix(Rowjsq, 4)) <> "" Then '发生日期
.TextMatrix(.Rows - 1, 1) = .TextMatrix(.Rows - 1, 1) + Space(2) + Trim(Cxsjwg.TextMatrix(Rowjsq, 4))
End If
If Val(Cxsjwg.TextMatrix(Rowjsq, 5)) <> 0 Then '数量
.TextMatrix(.Rows - 1, 1) = .TextMatrix(.Rows - 1, 1) + Space(2) + Trim(Cxsjwg.TextMatrix(Rowjsq, 5)) + Trim(Cxsjwg.TextMatrix(Rowjsq, 7))
End If
If Trim(Cxsjwg.TextMatrix(Rowjsq, 9)) <> "" Then '外币名称
.TextMatrix(.Rows - 1, 1) = .TextMatrix(.Rows - 1, 1) + Space(2) + Trim(Cxsjwg.TextMatrix(Rowjsq, 10)) + Trim(Cxsjwg.TextMatrix(Rowjsq, 9))
End If
If Val(Cxsjwg.TextMatrix(Rowjsq, 11)) <> 0 Then '记帐汇率
.TextMatrix(.Rows - 1, 1) = .TextMatrix(.Rows - 1, 1) + Space(2) + "汇率:" + Trim(Cxsjwg.TextMatrix(Rowjsq, 11))
End If
If Trim(Cxsjwg.TextMatrix(Rowjsq, 13)) <> "" Then '部门
.TextMatrix(.Rows - 1, 1) = .TextMatrix(.Rows - 1, 1) + Space(2) + Trim(Cxsjwg.TextMatrix(Rowjsq, 13))
End If
If Trim(Cxsjwg.TextMatrix(Rowjsq, 15)) <> "" Then '往来客户
.TextMatrix(.Rows - 1, 1) = .TextMatrix(.Rows - 1, 1) + Space(2) + Trim(Cxsjwg.TextMatrix(Rowjsq, 15))
End If
If Trim(Cxsjwg.TextMatrix(Rowjsq, 26)) <> "" Then '往来供应商
.TextMatrix(.Rows - 1, 1) = .TextMatrix(.Rows - 1, 1) + Space(2) + Trim(Cxsjwg.TextMatrix(Rowjsq, 26))
End If
If Trim(Cxsjwg.TextMatrix(Rowjsq, 17)) <> "" Then '职员
.TextMatrix(.Rows - 1, 1) = .TextMatrix(.Rows - 1, 1) + Space(2) + Trim(Cxsjwg.TextMatrix(Rowjsq, 17))
End If
If Trim(Cxsjwg.TextMatrix(Rowjsq, 19)) <> "" Then '项目大类
.TextMatrix(.Rows - 1, 1) = .TextMatrix(.Rows - 1, 1) + Space(2) + Trim(Cxsjwg.TextMatrix(Rowjsq, 19))
End If
If Trim(Cxsjwg.TextMatrix(Rowjsq, 21)) <> "" Then '项目名称
.TextMatrix(.Rows - 1, 1) = .TextMatrix(.Rows - 1, 1) + Space(2) + Trim(Cxsjwg.TextMatrix(Rowjsq, 21))
End If
If Val(Cxsjwg.TextMatrix(Rowjsq, 22)) <> 0 Then '项目数量单位
.TextMatrix(.Rows - 1, 1) = .TextMatrix(.Rows - 1, 1) + Space(2) + Trim(Cxsjwg.TextMatrix(Rowjsq, 22)) + Trim(Cxsjwg.TextMatrix(Rowjsq, 23))
End If
If Trim(Cxsjwg.TextMatrix(Rowjsq, 24)) <> "" Then '经办人
.TextMatrix(.Rows - 1, 1) = .TextMatrix(.Rows - 1, 1) + Space(2) + "经办人:" + Trim(Cxsjwg.TextMatrix(Rowjsq, 24))
End If
'借方金额
.TextMatrix(.Rows - 1, 2) = Cxsjwg.TextMatrix(Rowjsq, Sydz("004", GridStr(), Szzls))
'贷方金额
.TextMatrix(.Rows - 1, 3) = Cxsjwg.TextMatrix(Rowjsq, Sydz("005", GridStr(), Szzls))
End If '本张凭证非汇总打印
End If
Next Rowjsq
DY_Tybbyldy.DyylGrid.Cols = DY_Tybbyldy.DyylGrid.Cols - 1 '去除汇总打印辅助列
'===凭证数据输出完毕====
'补空行和添加分页合计
Int_Pzmyhs = 6
If .Rows - .FixedRows = 0 Then
Exit Sub
Else
If (.Rows - .FixedRows) Mod Int_Pzmyhs <> 0 Then
For Jsqte = 1 To Int_Pzmyhs - ((.Rows - .FixedRows) Mod Int_Pzmyhs)
.AddItem ""
.RowHeight(.Rows - 1) = Sjhgd
Next Jsqte
End If
End If
Dbl_Jfhj = 0
Dbl_Dfhj = 0
Sjhjsq = 1
Rowjsq = .FixedRows
Do While Rowjsq <= .Rows - 1
Dbl_Jfhj = Dbl_Jfhj + Val(.TextMatrix(Rowjsq, 2))
Dbl_Dfhj = Dbl_Dfhj + Val(.TextMatrix(Rowjsq, 3))
If Sjhjsq Mod Int_Pzmyhs = 0 Then
Rowjsq = Rowjsq + 1
.AddItem "", Rowjsq
.RowHeight(Rowjsq) = Sjhgd
.TextMatrix(Rowjsq, 0) = "合计"
.TextMatrix(Rowjsq, 2) = Format(Dbl_Jfhj, "##." + String(Xtjexsws, "0"))
.TextMatrix(Rowjsq, 3) = Format(Dbl_Dfhj, "##." + String(Xtjexsws, "0"))
'最后合计输出金额大写
If Rowjsq = .Rows - 1 Then
.TextMatrix(Rowjsq, 1) = Fun_Jezh(Dbl_Jfhj)
End If
End If
Sjhjsq = Sjhjsq + 1
Rowjsq = Rowjsq + 1
Loop
End With
End Sub
'===================以下程序为通用部分 ,一般不需更改======================='
Private Sub Sub_AdjustGrid()
'调整网格
With WglrGrid
'加 1 保持一行录入行
If .Rows < Pmbcsjhs + .FixedRows + Fzxwghs + 1 Then
.Rows = Pmbcsjhs + .FixedRows + Fzxwghs + 1
For Jsqte = .FixedRows To .Rows - 1
.RowHeight(Jsqte) = Sjhgd
Next Jsqte
Else
'判断是否有辅助行和录入行,如没有则加行
Do While .TextMatrix(.Rows - 1 - Fzxwghs, 0) = "*"
.AddItem ""
.RowHeight(.Rows - 1) = Sjhgd
Loop
End If
End With
End Sub
Private Sub Lrzdbz() '录入字段帮助
If Not Ydcommand.Visible Then
Exit Sub
End If
Valilock = True
With WglrGrid
'[>>会计科目编码帮助单独处理
If .Col = Sydz("002", GridStr(), Szzls) Then
Xtcdcs = Trim(Ydtext.Text)
PZ_FrmKjkmcz.Show 1
If Len(Xtfhcs) <> 0 Then
Ydtext.Text = Xtfhcs
End If
Else
'处理通用部分
changelock = True '调入另外窗体必须加锁
Call Drbmhelp(GridInt(.Col, 6), GridStr(.Col, 3), Trim(Ydtext.Text))
changelock = False
If Len(Xtfhcs) <> 0 Then
If GridInt(.Col, 7) = 0 Then
Ydtext.Text = Xtfhcs
Else
Ydtext.Text = Xtfhcsfz
End If
End If
End If
'[>>处理完毕
Valilock = False
If Ydtext.Visible Then
Ydtext.SetFocus
End If
End With
End Sub
Private Sub Cshhjwg() '初始化合计网格(*对合计网格来说,录入网格为容器)
Dim Lrwglkd As Double
Dim Hjwgpyl As Integer
With HjGrid
If Not Sfxshjwg Then
.Visible = False
Exit Sub
Else
.Visible = True
End If
.Enabled = False
.Appearance = flexFlat
.BorderStyle = flexBorderNone
.ScrollBars = flexScrollBarNone
.Width = WglrGrid.Width
.FixedRows = 0
.Rows = 1
.Cols = WglrGrid.Cols
.LeftCol = WglrGrid.LeftCol
.TextMatrix(0, Qslz) = "合计"
For Jsqte = 0 To WglrGrid.Cols - 1
.ColHidden(Jsqte) = WglrGrid.ColHidden(Jsqte)
.ColWidth(Jsqte) = WglrGrid.ColWidth(Jsqte)
.ColAlignment(Jsqte) = WglrGrid.ColAlignment(Jsqte)
.ColFormat(Jsqte) = WglrGrid.ColFormat(Jsqte)
Next Jsqte
.ColAlignment(Qslz) = flexAlignCenterTop
For Jsqte = .FixedRows To .Rows - 1
.RowHeight(Jsqte) = .Height / .Rows
Next Jsqte
.Move 0, WglrGrid.Height - .Height, WglrGrid.Width, .Height
End With
End Sub
Private Sub Form_Resize() '窗体大小发生变化时,重新显示文本框
Call Cxxswbk
End Sub
Private Function Fun_Drfrmyxxpd() As Boolean '调入其它窗体或功能产生的有效性判断(包括数据回写)
Fun_Drfrmyxxpd = True
With WglrGrid
'如果当前网格处于编辑状态,则先进行数据回写再进行有效性判断
If Ydtext.Visible Or YdCombo.Visible Then
Call Lrsjhx
If Not sjzdyxxpd(Dqlrwgh, Dqlrwgl) Then
Fun_Drfrmyxxpd = False
Exit Function
End If
End If
'进行行有效性判断
If Not Sjhzyxxpd(.Row) Then
Fun_Drfrmyxxpd = False
Exit Function
End If
End With
End Function
Private Sub WglrGrid_AfterUserResize(ByVal Row As Long, ByVal Col As Long) '调整列宽
If HjGrid.Visible Then
With HjGrid
.ColWidth(Col) = WglrGrid.ColWidth(Col)
End With
End If
End Sub
Private Sub WglrGrid_EnterCell() '显示当前数据行相关信息
With WglrGrid
If .Row >= .FixedRows Then
Lab_Row = Trim(Str(.Row - .FixedRows + 1))
'显示备注信息
Call Sub_ShowMemo(WglrGrid.Row)
End If
End With
End Sub
Private Sub WglrGrid_GotFocus() '网格得到焦点
'网格得到焦点,如果当前选择行为非数据行
'则调整当前焦点至有效数据行
With WglrGrid
If .Row < .FixedRows And .Rows > .FixedRows Then
changelock = True
.Select .FixedRows, .Col
changelock = False
End If
If .Col < Qslz Then
changelock = True
.Select .Row, Qslz
changelock = False
End If
End With
End Sub
Private Sub WglrGrid_LostFocus() '录入网格失去焦点
'用以屏蔽调用其它窗体时发生网格失去焦点事件
If changelock Then
Exit Sub
End If
'引发网格RowcolChange事件
With WglrGrid
If Not (Ydtext.Visible Or YdCombo.Visible) Then
.Select 0, 0
End If
End With
End Sub
Private Sub WglrGrid_AfterScroll(ByVal OldTopRow As Long, ByVal OldLeftCol As Long, ByVal NewTopRow As Long, ByVal NewLeftCol As Long) '限制用户在录入过程中滚动鼠标
If Gdtlock Then
Exit Sub
End If
With WglrGrid
If Ydtext.Visible Or YdCombo.Visible Then
Gdtlock = True
.TopRow = Dqtoprow
.LeftCol = Dqleftcol
Gdtlock = False
Exit Sub
End If
HjGrid.LeftCol = .LeftCol
End With
End Sub
Private Sub WglrGrid_LeaveCell() '离开单元格
If changelock Then
Exit Sub
End If
'记录刚刚离开网格单元的行列值
Dqlkwgh = WglrGrid.Row
Dqlkwgl = WglrGrid.Col
'判断是否需要录入数据回写
If Not (Ydtext.Visible Or YdCombo.Visible) Then
Exit Sub
End If
Call Lrsjhx
End Sub
Private Sub WglrGrid_RowColChange() '网格录入行列发生变化时,进行有效性判断
Valilock = True '屏蔽文本框失去焦点进行有效性判断
With WglrGrid
If changelock Then
Exit Sub
End If
If Not sjzdyxxpd(Dqlrwgh, Dqlrwgl) Then
Exit Sub
End If
If .Row <> Dqlkwgh Then
If Not Sjhzyxxpd(Dqlkwgh) Then
Exit Sub
End If
End If
End With
Call fhyxh
Call Xldql
End Sub
Private Sub WglrGrid_DblClick() '鼠标双击网格显示文本框
With WglrGrid
Call xswbk
End With
End Sub
Private Sub Ycwbk() '隐藏文本框,帮助按钮,列表组合框
Valilock = True
Ydtext.Visible = False
YdCombo.Visible = False
Ydcommand.Visible = False
End Sub
Private Sub YdCombo_KeyDown(KeyCode As Integer, Shift As Integer) '列表框移动
With WglrGrid
Select Case KeyCode
Case vbKeyEscape 'ESC 键放弃录入
Valilock = True
.SetFocus
Call Ycwbk
Valilock = False
Case vbKeyReturn '回车键 =13
KeyCode = 0
.SetFocus
Call Lrsjhx
Rowjsq = .Row
Coljsq = .Col + 1
If Coljsq > .Cols - 1 Then
If Rowjsq < .Rows - 1 Then
Rowjsq = Rowjsq + 1
End If
Coljsq = Qslz
End If
Do While Rowjsq <= .Rows - 1
If .ColHidden(Coljsq) Or (Not GridBoolean(Coljsq, 1)) Then
Coljsq = Coljsq + 1
If Coljsq > .Cols - 1 Then
Rowjsq = Rowjsq + 1
Coljsq = Qslz
End If
Else
Exit Do
End If
Loop
.Select Rowjsq, Coljsq
Case vbKeyLeft '左箭头 =37
If .Col - 1 = Qslz Then
If .ColHidden(Qslz) Or (Not GridBoolean(Qslz, 1)) Then
GoTo jzzx
End If
End If
If .Col > Qslz Then
KeyCode = 0
.SetFocus
Call Lrsjhx
Coljsq = .Col - 1
Do While Coljsq > Qslz
If Coljsq - 1 = Qslz Then
If .ColHidden(Qslz) Or (Not GridBoolean(Qslz, 1)) Then
GoTo jzzx
End If
End If
If .ColHidden(Coljsq) Or (Not GridBoolean(Coljsq, 1)) Then
Coljsq = Coljsq - 1
Else
Exit Do
End If
Loop
.Select .Row, Coljsq
End If
Case vbKeyRight '右箭头 =39
KeyCode = 0
.SetFocus
Call Lrsjhx
Rowjsq = .Row
Coljsq = .Col + 1
If Coljsq > .Cols - 1 Then
If Rowjsq < .Rows - 1 Then
Rowjsq = Rowjsq + 1
End If
Coljsq = Qslz
End If
Do While Rowjsq <= .Rows - 1
If .ColHidden(Coljsq) Or (Not GridBoolean(Coljsq, 1)) Then
Coljsq = Coljsq + 1
If Coljsq > .Cols - 1 Then
Rowjsq = Rowjsq + 1
Coljsq = Qslz
End If
Else
Exit Do
End If
Loop
.Select Rowjsq, Coljsq
Case Else
End Select
jzzx:
End With
End Sub
Private Sub YdCombo_LostFocus()
With WglrGrid '因为选中网格会先发生Rowcolchange事件置Valiock
If Not Valilock Then '为TRUE
Call Lrsjhx
If Not Sjhzyxxpd(Dqlrwgh) Then
Exit Sub
End If
End If
End With
End Sub
Private Sub Ydcommand_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
Call Lrzdbz
End Sub
Private Sub ydtext_KeyDown(KeyCode As Integer, Shift As Integer)
Dim Rowjsq As Long, Coljsq As Long
With WglrGrid
Select Case KeyCode
Case vbKeyF2
Call Lrzdbz
Case vbKeyEscape 'ESC 键放弃录入
Valilock = True
Call Ycwbk
.SetFocus
Case vbKeyReturn '回车键 =13
KeyCode = 0
.SetFocus
Call Lrsjhx
Rowjsq = .Row
Coljsq = .Col + 1
If Coljsq > .Cols - 1 Then
If Rowjsq < .Rows - 1 Then
Rowjsq = Rowjsq + 1
End If
Coljsq = Qslz
End If
Do While Rowjsq <= .Rows - 1
If .ColHidden(Coljsq) Or (Not GridBoolean(Coljsq, 1)) Then
Coljsq = Coljsq + 1
If Coljsq > .Cols - 1 Then
Rowjsq = Rowjsq + 1
Coljsq = Qslz
End If
Else
Exit Do
End If
Loop
If Rowjsq <= .Rows - 1 Then
.Select Rowjsq, Coljsq
End If
Case vbKeyUp '上箭头 =38
KeyCode = 0
.SetFocus
Call Lrsjhx
If .Row > .FixedRows Then
.Row = .Row - 1
End If
Case vbKeyDown '下箭头 =40
KeyCode = 0
.SetFocus
Call Lrsjhx
If .Row < .Rows - 1 Then
.Row = .Row + 1
End If
Case vbKeyLeft '左箭头 =37
If .Col - 1 = Qslz Then
If .ColHidden(Qslz) Or (Not GridBoolean(Qslz, 1)) Then
GoTo jzzx
End If
End If
If Ydtext.SelStart = 0 And .Col > Qslz Then
KeyCode = 0
.SetFocus
Call Lrsjhx
Coljsq = .Col - 1
Do While Coljsq > Qslz
If Coljsq - 1 = Qslz Then
If .ColHidden(Qslz) Or (Not GridBoolean(Qslz, 1)) Then
GoTo jzzx
End If
End If
If .ColHidden(Coljsq) Or (Not GridBoolean(Coljsq, 1)) Then
Coljsq = Coljsq - 1
Else
Exit Do
End If
Loop
.Select .Row, Coljsq
End If
jzzx:
Case vbKeyRight '右箭头 =39
wblong = Len(Ydtext.Text)
If (Ydtext.SelStart = wblong Or Ydtext.SelLength = wblong) Then
KeyCode = 0
.SetFocus
Call Lrsjhx
Rowjsq = .Row
Coljsq = .Col + 1
If Coljsq > .Cols - 1 Then
If Rowjsq < .Rows - 1 Then
Rowjsq = Rowjsq + 1
End If
Coljsq = Qslz
End If
Do While Rowjsq <= .Rows - 1
If .ColHidden(Coljsq) Or (Not GridBoolean(Coljsq, 1)) Then
Coljsq = Coljsq + 1
If Coljsq > .Cols - 1 Then
Rowjsq = Rowjsq + 1
Coljsq = Qslz
End If
Else
Exit Do
End If
Loop
.Select Rowjsq, Coljsq
End If
Case Else
End Select
End With
End Sub
Private Sub ydtext_KeyPress(KeyAscii As Integer) '录入字符事中控制
Call InputFieldLimit(Ydtext, GridInt(WglrGrid.Col, 1), KeyAscii)
If KeyAscii <> 0 Then
Call Xyxhbz(Dqlrwgh)
End If
End Sub
Private Sub ydtext_Change() '录入事中变化处理
'防止程序改变但不进行处理
If Wbkbhlock Then
Exit Sub
End If
With WglrGrid
'限制字段录入长度
Wbkbhlock = True
Select Case GridInt(.Col, 1)
Case 8
Call Sjgskz(Ydtext, Xtjezws - Xtjexsws - 1, Xtjexsws)
Case 9
Call Sjgskz(Ydtext, Xtslzws - Xtslxsws - 1, Xtslxsws)
Case 10
Call Sjgskz(Ydtext, Xtdjzws - Xtdjxsws - 1, Xtdjxsws)
Case Else
If GridInt(.Col, 3) <> 0 Or GridInt(.Col, 4) <> 0 Then
Call Sjgskz(Ydtext, GridInt(.Col, 3), GridInt(.Col, 4))
End If
End Select
Wbkbhlock = False
End With
End Sub
Private Sub ydtext_LostFocus() '如果由于选中网格之外的控件而发生有效性判断(选中网格会先发生Rowcolchange事件置Valiock为TRUE)
With WglrGrid
If Not Valilock Then
Call Lrsjhx
If Not sjzdyxxpd(Dqlrwgh, Dqlrwgl) Then
Exit Sub
End If
If Not Sjhzyxxpd(Dqlrwgh) Then
Exit Sub
End If
End If
End With
End Sub
Private Sub xswbk() '在当前选中单元显示文本框,列表框,帮助按钮(通用)
Dim Wbkpy As Integer, Wbkpy1 As Integer '文本框偏移量
'如果单据操作状态为浏览状态则不能显示录入载体
If Trim(Lab_OperStatus.Caption) = "1" Then
Exit Sub
End If
'显示文本框前返回有效行列（解决滚动条问题）
Call Xldqh
Call Xldql
'隐藏文本框,帮助按钮,列表组合框
Call Ycwbk
With WglrGrid
Dqlrwgh = .Row
Dqlrwgl = .Col
If Not GridBoolean(.Col, 1) Or .Row < .FixedRows Then
Exit Sub
End If
Wbkpy = 30
Wbkpy1 = 15
If GridBoolean(.Col, 3) Then
YdCombo.Left = .CellLeft + .Left + Wbkpy
YdCombo.Top = .CellTop + .Top + Wbkpy
YdCombo.Width = .CellWidth - Wbkpy1
Call Wbkcl
YdCombo.Visible = True
YdCombo.SetFocus
Ydcommand.Visible = False
Ydtext.Visible = False
Else
If GridBoolean(.Col, 2) Then
Ydcommand.Left = .Left + .CellLeft + .CellWidth - Ydcommand.Width + Wbkpy
Ydcommand.Top = .Top + .CellTop + .CellHeight - Ydcommand.Height + Wbkpy
Ydcommand.Visible = True
Else
Ydcommand.Visible = False
End If
Ydtext.Left = .CellLeft + .Left + Wbkpy
Ydtext.Top = .CellTop + .Top + Wbkpy
If Ydcommand.Visible Then
If Sfblbzkd Then
Ydtext.Width = .CellWidth - Ydcommand.Width
Else
Ydtext.Width = .CellWidth - Wbkpy1
End If
Else
Ydtext.Width = .CellWidth - Wbkpy1
End If
Ydtext.Height = .CellHeight - Wbkpy1
If GridInt(.Col, 2) <> 0 Then
Ydtext.MaxLength = GridInt(.Col, 2)
Else
Ydtext.MaxLength = 3000
End If
Call Wbkcl
Ydtext.Visible = True
Ydtext.SetFocus
End If
Dqtoprow = .TopRow
Dqleftcol = .LeftCol
'重置锁值
Valilock = False
Wbkbhlock = False
End With
End Sub
Private Sub Cxxswbk() 'Formresize中重新显示文本框,列表框,帮助按钮(通用)
Dim Wbkpy As Integer, Wbkpy1 As Integer
Wbkpy = 30
Wbkpy1 = 15
With WglrGrid
If YdCombo.Visible Then
YdCombo.Left = .CellLeft + .Left + Wbkpy
YdCombo.Top = .CellTop + .Top + Wbkpy
YdCombo.Width = .CellWidth - Wbkpy1
End If
If Ydcommand.Visible Then
Ydcommand.Left = .Left + .CellLeft + .CellWidth - Ydcommand.Width + Wbkpy
Ydcommand.Top = .Top + .CellTop + .CellHeight - Ydcommand.Height + Wbkpy
End If
If Ydtext.Visible Then
If Ydcommand.Visible Then
If Sfblbzkd Then
Ydtext.Width = .CellWidth - Ydcommand.Width
Else
Ydtext.Width = .CellWidth - Wbkpy1
End If
Else
Ydtext.Width = .CellWidth - Wbkpy1
End If
Ydtext.Left = .CellLeft + .Left + Wbkpy
Ydtext.Top = .CellTop + .Top + Wbkpy
Ydtext.Height = .CellHeight - Wbkpy1
End If
End With
End Sub
Private Sub Lrsjhx() '文本框录入数据回写
With WglrGrid
If YdCombo.Visible Then
.Text = Trim(YdCombo.Text)
End If
If Ydtext.Visible Then
.Text = Trim(Ydtext.Text)
End If
'(如果字段录入内容发生变化,则打开有效性判断锁)
If Zdlrqnr <> Trim(.Text) Then
Yxxpdlock = False
Hyxxpdlock = False
End If
'如果字段录入内容不为空则写数据行有效性标志
If Len(Trim(.Text)) <> 0 Then
Call Xyxhbz(.Row)
End If
'隐藏文本框,帮助按钮,列表组合框
Call Ycwbk
End With
End Sub
Private Sub WglrGrid_KeyDown(KeyCode As Integer, Shift As Integer) '网格录入增行，删行快捷键
'如果单据操作状态为浏览状态则不能显示录入载体
If Trim(Lab_OperStatus.Caption) = "1" Then
Exit Sub
End If
Select Case KeyCode
Case vbKeyDelete '删行
Call Scdqfl
Case vbKeyInsert '增行
Call zjlrfl
End Select
End Sub
Private Sub WglrGrid_KeyPress(KeyAscii As Integer) '网格接受键盘录入
Dim Str_ChangeTe As String '临时交换内容
Dim Coljsq As Long '临时列计数器
Dim Int_SaveKey As Integer '保存KeyAscii值
'如果单据操作状态为浏览状态则不能显示录入载体
If Trim(Lab_OperStatus.Caption) = "1" Then
Exit Sub
End If
Int_SaveKey = KeyAscii
With WglrGrid
'屏蔽回车键
If KeyAscii = vbKeyReturn Then
KeyAscii = 0
Rowjsq = .Row
Coljsq = .Col + 1
If Coljsq > .Cols - 1 Then
If Rowjsq < .Rows - 1 Then
Rowjsq = Rowjsq + 1
End If
Coljsq = Qslz
End If
Do While Rowjsq <= .Rows - 1
If .ColHidden(Coljsq) Or (Not GridBoolean(Coljsq, 1)) Then
Coljsq = Coljsq + 1
If Coljsq > .Cols - 1 Then
Rowjsq = Rowjsq + 1
Coljsq = Qslz
End If
Else
Exit Do
End If
Loop
If Rowjsq <= .Rows - 1 Then
.Select Rowjsq, Coljsq
End If
Exit Sub
End If
'接受用户录入
Select Case KeyAscii
Case 0 To 32
'[>>开始当用户输入空格时,如果在摘要列则自动填入上条记录录入的摘要内容
' 如果在金额列则交换借贷内容,此段程序不要求有效性判断,否则应另行处理
Select Case GridStr(.Col, 1)
Case "001" '摘要
If Len(Trim(WglrGrid.TextMatrix(.Row, .Col))) = 0 And Len(Trim(Str_Digest)) <> 0 Then
WglrGrid.TextMatrix(.Row, .Col) = Str_Digest
'写有效行数据标志,并打开行有效性判断锁
Call Xyxhbz(.Row)
Hyxxpdlock = False
End If
Case "004", "005" '借方金额,贷方金额
If Val(WglrGrid.TextMatrix(.Row, .Col)) = 0 Then
Str_ChangeTe = WglrGrid.TextMatrix(.Row, Sydz("004", GridStr(), Szzls))
WglrGrid.TextMatrix(.Row, Sydz("004", GridStr(), Szzls)) = WglrGrid.TextMatrix(.Row, Sydz("005", GridStr(), Szzls))
WglrGrid.TextMatrix(.Row, Sydz("005", GridStr(), Szzls)) = Str_ChangeTe
'写有效行数据标志,并打开行有效性判断锁
Call Xyxhbz(.Row)
Hyxxpdlock = False
'计算合计数据
For Coljsq = Qslz To .Cols - 1
Call Sjhj(Coljsq)
Next Coljsq
End If
End Select
'完毕<<]
'显示录入载体
Call xswbk
Case Else
'防止非编辑字段SendKeys()出现死循环
If Not GridBoolean(.Col, 1) Or .Row < .FixedRows Then
Exit Sub
End If
If GridBoolean(.Col, 3) Then
'列表框录入
Call xswbk
Else
'[>>开始如果用户在借贷金额位置按"="且当前行金额为零则自动计算借贷合计差额填入录入文本框
If Chr(KeyAscii) = "=" And (Val(.TextMatrix(.Row, Sydz("004", GridStr(), Szzls))) = 0 And Val(.TextMatrix(.Row, Sydz("005", GridStr(), Szzls))) = 0) Then
Select Case GridStr(.Col, 1)
Case "004" '借方金额
Ydtext.Text = ""
Call Xyxhbz(.Row)
Call xswbk
Ydtext.Text = Format(Val(HjGrid.TextMatrix(0, Sydz("005", GridStr(), Szzls))) - Val(HjGrid.TextMatrix(0, .Col)), "##." + String(Xtjexsws, "0"))
Case "005" '贷方金额
Ydtext.Text = ""
Call Xyxhbz(.Row)
Call xswbk
Ydtext.Text = Format(Val(HjGrid.TextMatrix(0, Sydz("004", GridStr(), Szzls))) - Val(HjGrid.TextMatrix(0, .Col)), "##." + String(Xtjexsws, "0"))
End Select
'完毕<<]
Else
Ydtext.Text = ""
Call InputFieldLimit(Ydtext, GridInt(WglrGrid.Col, 1), KeyAscii)
If KeyAscii = 0 Then
Exit Sub
End If
'写有效行数据标志
Call Xyxhbz(.Row)
Call xswbk
Ydtext.Text = ""
Valilock = True
SendKeys Chr(KeyAscii), True
DoEvents
Valilock = False
End If
End If
End Select
End With
End Sub
Private Sub zjlrfl() '增加录入分录
With WglrGrid
If Not (Ydtext.Visible Or YdCombo.Visible) Then
If Not Fun_Drfrmyxxpd Then
Exit Sub
End If
Else
Exit Sub
End If
If .Row < .FixedRows Then
Exit Sub
End If
.AddItem "", .Row
.RowHeight(.Row) = Sjhgd
If .Row <> .Rows - 1 Then
If .TextMatrix(.Row + 1, 0) = "*" Then
.TextMatrix(.Row, 0) = "*"
Else
.RemoveItem .Rows - 1
End If
End If
Call Xldqh
Call Xldql
Hyxxpdlock = False
End With
End Sub
Private Sub Scdqfl() '删除当前分录
Dim Answer As Integer, Scqwghz As Long, Scqwglz As Long, Hjlzte As Long, Sflrzt As Boolean
With WglrGrid
Scqwghz = .Row
Scqwglz = .Col
If .TextMatrix(.Row, 0) = "*" Then
'判断是否为录入状态
If Ydtext.Visible Or YdCombo.Visible Then
Sflrzt = True
Validate = True
Call Lrsjhx
Validate = False
End If
Call Xldqh
changelock = True
.Select .Row, 0
changelock = False
If Shsfts Then
.Cell(flexcpBackColor, .Row, Qslz, .Row, .Cols - 1) = QBColor(12)
Tsxx = "请确认是否删除当前记录?"
Yhanswer = Xtxxts(Tsxx, 2, 2)
If Yhanswer = 2 Then
.Cell(flexcpBackColor, .Row, Qslz, .Row, .Cols - 1) = &H80000005
changelock = True
.Select Scqwghz, Scqwglz
changelock = False
'如为录入状态,则恢复录入
If Sflrzt Then
Call xswbk
End If
Exit Sub
End If
End If
.RemoveItem .Row
If .Rows < Pmbcsjhs + .FixedRows + Fzxwghs + 1 Then
.AddItem ""
.RowHeight(.Rows - 1) = Sjhgd
End If
changelock = True
.Select .Row, Scqwglz
changelock = False
'重新计算合计数据
For Hjlzte = Qslz To .Cols - 1
Call Sjhj(Hjlzte)
Next Hjlzte
End If
End With
End Sub
Private Sub Sjhj(Hjwgl As Long) '网格列数据合计
Dim Hjjg As Double
If Not (GridBoolean(Hjwgl, 4) And HjGrid.Visible) Then
Exit Sub
End If
With WglrGrid
Hjjg = 0
For Jsqte = .FixedRows To .Rows - 1
If .TextMatrix(Jsqte, 0) = "*" Then
Hjjg = Hjjg + Val(.TextMatrix(Jsqte, Hjwgl))
End If
Next Jsqte
If GridBoolean(Hjwgl, 5) And Hjjg = 0 Then
HjGrid.TextMatrix(0, Hjwgl) = ""
Else
HjGrid.TextMatrix(0, Hjwgl) = Hjjg
End If
End With
End Sub
Private Sub Qkwlzd(sjh As Long, Sjl As Long) '清空为零字段
If Not GridBoolean(Sjl, 5) Then
Exit Sub
End If
With WglrGrid
If Val(Trim(.TextMatrix(sjh, Sjl))) = 0 Then
.TextMatrix(sjh, Sjl) = ""
End If
End With
End Sub
Private Sub fhyxh() '返回录入数据有效行,同时让得到焦点网格可见
With WglrGrid
If .Row >= .FixedRows Then
If .TextMatrix(.Row, 0) <> "*" Then
For Rowjsq = .FixedRows To .Rows - 1
If .TextMatrix(Rowjsq, 0) <> "*" Then
Exit For
End If
Next Rowjsq
If Rowjsq <= .Rows - 1 Then
changelock = True
.Select Rowjsq, .Col
changelock = False
Else
changelock = True
.Select .Rows - 1, .Col
changelock = False
End If
End If
Call Xldqh
End If
End With
End Sub
Private Sub Xldqh() '显露当前行
Dim Toprowte As Long
With WglrGrid
Toprowte = 0
Do While .CellTop + .RowHeight(.Row) + Fzxwghs * Sjhgd > .Height And .TopRow <> Toprowte
Toprowte = .TopRow
.TopRow = .TopRow + 1
Loop
Toprowte = 0
Do While .CellTop < .FixedRows * .RowHeight(0) And .TopRow <> Toprowte
Toprowte = .TopRow
If .TopRow > 1 Then
.TopRow = .TopRow - 1
End If
Loop
End With
End Sub
Private Sub Xldql() '显露当前列
Dim Leftcolte As Long
With WglrGrid
If .Col >= Qslz Then
If .LeftCol > .Col Then
.LeftCol = .Col
End If
Leftcolte = 0
Do While .CellLeft + .CellWidth > .Width And .LeftCol <> Leftcolte
Leftcolte = .LeftCol
.LeftCol = .LeftCol + 1
Loop
End If
End With
End Sub
Private Function pdhwk(sjh As Long) '判断网格行是否为空行(所有录入字段均为空*非录入字段除外)
With WglrGrid
For Coljsq = Qslz To .Cols - 1
If Len(Trim(.TextMatrix(sjh, Coljsq))) <> 0 And GridBoolean(Coljsq, 1) Then
pdhwk = False
Exit Function
End If
Next Coljsq
pdhwk = True
End With
End Function
Private Sub Xyxhbz(sjh As Long) '写行有效性标志,并判断是否增行
With WglrGrid
If .TextMatrix(sjh, 0) = "*" Then
Exit Sub
End If
.TextMatrix(sjh, 0) = "*"
If sjh >= .Rows - Fzxwghs - 1 Then
.AddItem ""
.RowHeight(.Rows - 1) = Sjhgd
End If
End With
End Sub
Private Sub GsToolbar_ButtonClick(ByVal Button As MSComctlLib.Button) '表格格式设置(通用)
Select Case Button.Key
Case "bcgs" '保存表格格式
Call Bcwggs(WglrGrid, GridCode, GridStr)
Case "hfmrgs" '恢复默认格式
Call Hfmrgs(WglrGrid, GridCode, GridStr)
End Select
End Sub
Private Sub bbyl(bbylte As Boolean) '打印预览(通用)
Dim Bbzbt$, Bbxbt() As String, bbxbtzzxs() As Integer, Bbxbtgs As Integer
Dim Bbbwh() As String, Bbbwhzzxs() As Integer, Bbbwhgs As Integer
Bbxbtgs = 1 '报表小标题行数
Bbbwhgs = 1 '报表表尾行数
ReDim Bbxbt(1 To Bbxbtgs)
ReDim bbxbtzzxs(1 To Bbxbtgs)
If Bbbwhgs <> 0 Then
ReDim Bbbwh(1 To Bbbwhgs)
ReDim Bbbwhzzxs(1 To Bbbwhgs)
End If
Bbzbt = ReportTitle
Bbxbt(1) = Space(45) + Fun_FormatOutPut("制单日期:" + Trim(LrText(1).Text), 30)
Bbxbt(1) = Bbxbt(1) + Fun_FormatOutPut("凭证字号:" + Trim(LrText(0).Text) + "-" + Trim(LrText(3).Text), 26)
Bbbwh(1) = Fun_FormatOutPut("会计主管:", 18) + Fun_FormatOutPut("记帐:" + Lab_Book, 18)
Bbbwh(1) = Bbbwh(1) + Fun_FormatOutPut("出纳:", 18) + Fun_FormatOutPut("审核:" + Lab_Checker, 18)
Bbbwh(1) = Bbbwh(1) + Fun_FormatOutPut("制单:" + Lab_Bill, 18) + Trim(Fun_FormatOutPut("附单据数:" + Trim(LrText(2).Text), 23))
bbxbtzzxs(1) = 0 '报表行组织形式(0-居左 1-居中 2-居右)
Bbbwhzzxs(1) = 1
Call Sub_Scpzbb(WglrGrid) '生成报表数据(自定义程序)
Call Scdybb(Dyymctbl, Bbzbt, Bbxbt(), bbxbtzzxs(), Bbxbtgs, Bbbwh(), Bbbwhzzxs(), Bbbwhgs, bbylte)
If Not bbylte Then
Unload DY_Tybbyldy
End If
End Sub
'************以下为文本框录入处理程序(固定不变部分)*************'
Private Sub Wbklrwbcl(Index As Integer) '文本框录入事后处理程序
'以下为依据实际情况自定义部分[
'在此填写文本框录入事后处理程序
']以上为依据实际情况自定义部分
End Sub
Private Sub LrText_Change(Index As Integer)
'屏蔽程序改变控制
If TextChangeLock Then
Exit Sub
End If
TextValiJudgeLock(Index) = False '打开有效性判断锁
'限制字段录入长度
TextChangeLock = True '加锁(防止执行Lrtext_Change)
Select Case Textint(Index, 1)
Case 8 '金额型
Call Sjgskz(LrText(Index), Xtjezws - Xtjexsws - 1, Xtjexsws)
Case 9 '数量型
Call Sjgskz(LrText(Index), Xtslzws - Xtslxsws - 1, Xtslxsws)
Case 10 '单价型
Call Sjgskz(LrText(Index), Xtdjzws - Xtdjxsws - 1, Xtdjxsws)
Case Else '其他小数类型控制
If Textint(Index, 6) <> 0 Or Textint(Index, 7) <> 0 Then
Call Sjgskz(LrText(Index), Textint(Index, 6), Textint(Index, 7))
End If
End Select
'[>>随时计算最新单据号
If Index = 0 Then
Call Sub_JsVouchNo
End If
'<<]
TextChangeLock = False '解锁
End Sub
Private Sub LrText_GotFocus(Index As Integer) '文本框得到焦点,显示相应信息
Call TextShow(Index)
End Sub
Private Sub LrText_KeyDown(Index As Integer, KeyCode As Integer, Shift As Integer) '字段按F2键提供帮助
Select Case KeyCode
Case vbKeyF2
Call Text_Help(Index)
End Select
End Sub
Private Sub LrText_KeyPress(Index As Integer, KeyAscii As Integer) '文本框录入事中控制
Call InputFieldLimit(LrText(Index), Textint(Index, 1), KeyAscii)
End Sub
Private Sub LrText_LostFocus(Index As Integer) '文本框失去焦点进行有效性判断及相应处理
If Textint(Index, 9) = 0 Or Textint(Index, 9) = 1 Then '事中判断
Call TextYxxpd(Index)
End If
End Sub
Private Sub Ydcommand1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
Call Text_Help(Ydcommand1.Tag)
End Sub
Private Sub Text_Help(Index As Integer) '录入字段帮助
If Not Ydcommand1.Visible Then
Exit Sub
End If
TextValiLock = True
Call Drbmhelp(Textint(Index, 2), Textstr(Index, 4), Trim(LrText(Index).Text))
If Len(Xtfhcs) <> 0 Then
If Textint(Index, 3) = 1 Then
LrText(Index).Text = Xtfhcsfz
LrText(Index).Tag = Xtfhcs
Else
LrText(Index).Text = Xtfhcs
LrText(Index).Tag = Xtfhcsfz
End If
End If
TextValiLock = False
LrText(Index).SetFocus
End Sub
Private Sub TextShow(Index As Integer) '文本框得到焦点,显示相应信息
If Textboolean(Index, 1) Then
Ydcommand1.Visible = True
Ydcommand1.Move LrText(Index).Left + LrText(Index).Width, LrText(Index).Top
Ydcommand1.Tag = Index
Else
Ydcommand1.Tag = ""
Ydcommand1.Visible = False
End If
End Sub
Private Sub Wbkcsh() '录入文本框初始化
'最大录入文本框索引值
Max_Text_Index = Textvar(1)
ReDim TextValiJudgeLock(Max_Text_Index)
For Jsqte = 0 To Max_Text_Index
If Len(Trim(Textstr(Jsqte, 1))) <> 0 Then
TextChangeLock = True
LrText(Jsqte).Text = ""
LrText(Jsqte).Tag = ""
If Textint(Jsqte, 5) <> 0 Then
LrText(Jsqte).MaxLength = Textint(Jsqte, 5)
End If
TextChangeLock = False
End If
TextValiJudgeLock(Jsqte) = True
Next Jsqte
End Sub
Private Function TextYxxpd(Index As Integer) As Boolean '文本框有效性判断
Dim Sqlstr As String
Dim Findrec As New ADODB.Recordset
'按帮助不进行有效性判断
If TextValiLock Then
TextValiLock = False
TextYxxpd = True
Exit Function
End If
'文本框内容未曾改变不进行有效性判断
If TextValiJudgeLock(Index) Then
Ydcommand1.Visible = False
TextYxxpd = True
Exit Function
End If
If Trim(LrText(Index)) = "" Then
LrText(Index).Tag = ""
Call Wbklrwbcl(Index)
Ydcommand1.Visible = False
TextValiJudgeLock(Index) = True
TextYxxpd = True
'[>>如果凭证类别清空，则字号应清空
If Index = 0 Then
TextChangeLock = True
LrText(3).Text = ""
TextChangeLock = False
End If
'<<]
Exit Function
End If
Select Case Textint(Index, 4)
Case 1 '编码型
Sqlstr = Trim(Textstr(Index, 5))
Sqlstr = Replace(Sqlstr, "@", "'" + Trim(LrText(Index).Text) + "'")
Set Findrec = Cw_DataEnvi.DataConnect.Execute(Sqlstr)
If Findrec.EOF Then
Call Xtxxts(Trim(Textstr(Index, 6)), 0, 1)
Exit Function
Else
Select Case Textint(Index, 3)
Case 0
If Len(Trim(Textstr(Index, 2))) <> 0 Then
LrText(Index).Text = Trim(Findrec.Fields(Trim(Textstr(Index, 2))))
End If
If Len(Trim(Textstr(Index, 3) & "")) <> 0 Then
LrText(Index).Tag = Trim(Findrec.Fields(Trim(Textstr(Index, 3))))
End If
Case 1
If Len(Trim(Textstr(Index, 3) & "")) <> 0 Then
LrText(Index).Text = Trim(Findrec.Fields(Trim(Textstr(Index, 3))))
End If
If Len(Trim(Textstr(Index, 2))) <> 0 Then
LrText(Index).Tag = Trim(Findrec.Fields(Trim(Textstr(Index, 2))))
End If
End Select
End If
'[>>凭证类别如有效,且内容已经发生改变则自动计算类别字号
If Index = 0 Then
Call Sub_JsVouchNo
End If
'<<]
Case 2 '日期型
If IsDate(LrText(Index).Text) Then
LrText(Index).Text = Format(LrText(Index).Text, "yyyy-mm-dd")
Else
Tsxx = "非法公历日期!(格式:" + Format(Date, "yyyy-mm-dd") + ")"
Call Xtxxts(Tsxx, 0, 1)
Exit Function
End If
Case 3 '其他类型
End Select
Ydcommand1.Visible = False
TextValiJudgeLock(Index) = True
TextYxxpd = True
End Function
'以下为现金流量分配处理程序
'Modify by 奚峻峰
'
Private Sub Fp_Xjll() '分配现金流量
Dim Int_Year As Integer
Dim Int_Period As Integer
Dim Rec_AccVouch As New ADODB.Recordset
Int_Year = Val(Mid(Combo_Kjqj.Text, 1, 4))
Int_Period = Val(Mid(Combo_Kjqj.Text, 6, 2))
Sqlstr = "Select VouchID From Cwzz_AccVouchMain Where Year=" & Int_Year & " and Period=" & Int_Period & " And VouchClassCode='" & Trim(LrText(0).Text) & "' And VouchNo=" & Val(LrText(3).Text)
Set Rec_AccVouch = Cw_DataEnvi.DataConnect.Execute(Sqlstr)
If Rec_AccVouch.EOF = False Then
Xtcdcs = Rec_AccVouch.Fields("VouchId")
XJ_FrmXjllsjtz.Show 1
End If
End Sub
Private Function Sf_CashFlow() As Boolean '判断该凭证是否进行现金流量分配
Dim Int_Year As Integer
Dim Int_Period As Integer
Dim Rec_AccVouch As New ADODB.Recordset
Sf_CashFlow = False
If Chk_Xjll.Value = 1 Then
Int_Year = Val(Mid(Combo_Kjqj.Text, 1, 4))
Int_Period = Val(Mid(Combo_Kjqj.Text, 6, 2))
Sqlstr = "SELECT dbo.Cwzz_AccVouchMain.[Year],dbo.Cwzz_AccVouchMain.Period,dbo.Cwzz_AccVouchSub.VouchId,dbo.Cwzz_AccCode.CashFlowFlag " & _
"FROM dbo.Cwzz_AccCode RIGHT OUTER JOIN dbo.Cwzz_AccVouchSub ON " & _
"dbo.Cwzz_AccCode.Ccode = dbo.Cwzz_AccVouchSub.Ccode LEFT OUTER JOIN " & _
"dbo.Cwzz_AccVouchMain ON dbo.Cwzz_AccVouchSub.VouchId = dbo.Cwzz_AccVouchMain.VouchId " & _
"Where Year=" & Int_Year & " and Period=" & Int_Period & " And VouchClassCode='" & Trim(LrText(0).Text) & "' And VouchNo='" & Val(LrText(3).Text) & "'"
Set Rec_AccVouch = Cw_DataEnvi.DataConnect.Execute(Sqlstr)
If Rec_AccVouch.EOF = False Then
Do While Rec_AccVouch.EOF = False
If Rec_AccVouch.Fields("CashFlowFlag") = True Then
Sf_CashFlow = True
End If
Rec_AccVouch.MoveNext
Loop
End If
End If
End Function