企业管理

开发平台：

Visual Basic

：源码内容

rst_Temp.MoveFirst
If rst_Temp.Fields("ItemValue") = 1 Then
Tsxx = "期初发票已经结帐!"
Call Xtxxts(Tsxx, 0, 4)
Exit Function
Else
Set rst_Temp = Cw_DataEnvi.DataConnect.Execute("SELECT Kjyear, Period FROM Gy_kjrlb where BeginFlag=1")
If rst_Temp.RecordCount <> 0 Then
Int_Year = rst_Temp.Fields("Kjyear").Value
Int_Period = rst_Temp.Fields("Period").Value
Else
Tsxx = "会计期间表中未设开账月份!"
Call Xtxxts(Tsxx, 0, 4)
Exit Function
End If
End If
Else
Int_Year = Xtyear
Int_Period = Xtmm
End If
Case Else
Set rst_Temp = Cw_DataEnvi.DataConnect.Execute("SELECT * FROM Gy_kjrlb WHERE (CgJzbz = 1) AND (CONVERT(datetime, '" & Trim(LrText(0).Text) & "') BETWEEN Qsrq AND Zzrq) ")
If rst_Temp.RecordCount <> 0 Then
Tsxx = "发票日期所在的会计期间已经结帐!"
Call Xtxxts(Tsxx, 0, 4)
Exit Function
Else
If Year(CDate(LrText(0).Text)) < Xtyear Then
Tsxx = "发票日期中的年份不能小于当前会计年!"
Call Xtxxts(Tsxx, 0, 4)
Exit Function
End If
End If
Set rst_Temp = Cw_DataEnvi.DataConnect.Execute("SELECT * FROM Gy_kjrlb WHERE (CONVERT(datetime, '" & Trim(LrText(0).Text) & "') BETWEEN Qsrq AND Zzrq) ")
If rst_Temp.RecordCount <> 0 Then
Int_Year = rst_Temp.Fields("kjyear")
Int_Period = rst_Temp.Fields("period")
Else
Tsxx = "发票日期不在会计年月内!"
Call Xtxxts(Tsxx, 0, 4)
Exit Function
End If
End Select
rst_Temp.Close
Set rst_Temp = Nothing
'汇率不能为零
If Not IsNumeric(Trim(LrText(13).Text)) Then
Tsxx = "汇率必须为数字!"
Call Xtxxts(Tsxx, 0, 4)
Exit Function
ElseIf S2N(LrText(13).Text) = 0 Then
Tsxx = "汇率不能为零!"
Call Xtxxts(Tsxx, 0, 4)
Exit Function
End If
'<<]
'[>>下面将对所有有效数据行进行有效性判断
Lng_RowCount = 0
With WglrGrid
For Rowjsq = .FixedRows To .Rows - 1
'带*号者为有效数据行(Fixed)
If .TextMatrix(Rowjsq, 0) <> "*" Then
Exit For
Else
Lng_RowCount = Lng_RowCount + 1
End If
'1.首先进行为空或为零判断(Fixed)
For Coljsq = Qslz To .Cols - 1
If (GridInt(Coljsq, 5) = 1 And Len(Trim("" & .TextMatrix(Rowjsq, Coljsq))) = 0) Then
If Not .ColHidden(Coljsq) Then
Tsxx = GridStr(Coljsq, 2)
Lrywlz = Coljsq
GoTo Lrcwcl
Exit For
End If
End If
If GridInt(Coljsq, 5) = 2 Then
If Not .ColHidden(Coljsq) Then
If S2N(Trim("" & .TextMatrix(Rowjsq, Coljsq))) = 0 Then
Tsxx = GridStr(Coljsq, 2)
Lrywlz = Coljsq
GoTo Lrcwcl
Exit For
End If
End If
End If
Next Coljsq
'2.判断存货编码是否存在(Define)
Sqlstr = "SELECT MNumber From Gy_Material Where MNumber='" & Trim(.TextMatrix(Rowjsq, Sydz("001", GridStr(), Szzls))) & "' and IsPurchase=1 "
Set RecTemp = Cw_DataEnvi.DataConnect.Execute(Sqlstr)
If RecTemp.EOF Then
Tsxx = "此物料编码不存在!"
Lrywlz = Sydz("001", GridStr(), Szzls)
GoTo Lrcwcl
End If
For int_temp = .FixedRows To .Rows - 1
If .TextMatrix(int_temp, 0) = "*" And int_temp <> Rowjsq Then
If .TextMatrix(Rowjsq, Sydz("001", GridStr(), Szzls)) = .TextMatrix(int_temp, Sydz("001", GridStr(), Szzls)) Then
Tsxx = "物料编码与第" & int_temp - .FixedRows + 1 & "行分录物料编码重复!"
Lrywlz = Sydz("001", GridStr(), Szzls)
GoTo Lrcwcl
End If
End If
int_temp = int_temp + 1
Next int_temp
Next Rowjsq
'单据分录行数不能为零(Fixed)
If Lng_RowCount = 0 Then
Tsxx = "单据分录行数不能为零!"
Call Xtxxts(Tsxx, 0, 1)
Exit Function
End If
'[>>
'此处可以定义整张单据不能通过有效性检查的理由
'<<]
End With '网格
'计算发票金额
Dbl_MoneyYb = 0
Dbl_MoneyBb = 0
For Rowjsq = WglrGrid.FixedRows To WglrGrid.Rows - 1
If WglrGrid.TextMatrix(Rowjsq, 0) <> "*" Then
Exit For
End If
Select Case Me.InvoiceType '发票类型
Case 1, 3 '蓝字普通发票
Dbl_MoneyYb = S2N(Format(S2N(WglrGrid.TextMatrix(Rowjsq, Sydz("007", GridStr(), Szzls))), "####." + String(Xtjexsws, "0"))) + Dbl_MoneyYb
If S2N(LrText(13).Tag) = 0 Then
Dbl_MoneyBb = S2N(Format(S2N(WglrGrid.TextMatrix(Rowjsq, Sydz("007", GridStr(), Szzls))) * S2N(LrText(13).Text), "####." + String(Xtjexsws, "0"))) + Dbl_MoneyBb
Else
Dbl_MoneyBb = S2N(Format(S2N(WglrGrid.TextMatrix(Rowjsq, Sydz("007", GridStr(), Szzls))) / S2N(LrText(13).Text), "####." + String(Xtjexsws, "0"))) + Dbl_MoneyBb
End If
Case 2, 4 '蓝字专用发票
Dbl_MoneyYb = S2N(Format(S2N(WglrGrid.TextMatrix(Rowjsq, Sydz("010", GridStr(), Szzls))), "####." + String(Xtjexsws, "0"))) + Dbl_MoneyYb
If S2N(LrText(13).Tag) = 0 Then
Dbl_MoneyBb = S2N(Format(S2N(WglrGrid.TextMatrix(Rowjsq, Sydz("010", GridStr(), Szzls))) * S2N(LrText(13).Text), "####." + String(Xtjexsws, "0"))) + Dbl_MoneyBb
Else
Dbl_MoneyBb = S2N(Format(S2N(WglrGrid.TextMatrix(Rowjsq, Sydz("010", GridStr(), Szzls))) / S2N(LrText(13).Text), "####." + String(Xtjexsws, "0"))) + Dbl_MoneyYb
End If
Case 5 '红字普通发票
Dbl_MoneyYb = S2N(Format((-1) * S2N(WglrGrid.TextMatrix(Rowjsq, Sydz("007", GridStr(), Szzls))), "####." + String(Xtjexsws, "0"))) + Dbl_MoneyYb
If S2N(LrText(13).Tag) = 0 Then
Dbl_MoneyBb = S2N(Format((-1) * S2N(WglrGrid.TextMatrix(Rowjsq, Sydz("007", GridStr(), Szzls))) * S2N(LrText(13).Text), "####." + String(Xtjexsws, "0"))) + Dbl_MoneyBb
Else
Dbl_MoneyBb = S2N(Format((-1) * S2N(WglrGrid.TextMatrix(Rowjsq, Sydz("007", GridStr(), Szzls))) / S2N(LrText(13).Text), "####." + String(Xtjexsws, "0"))) + Dbl_MoneyBb
End If
Case 6 '红字专用发票
Dbl_MoneyYb = S2N(Format((-1) * S2N(WglrGrid.TextMatrix(Rowjsq, Sydz("010", GridStr(), Szzls))), "####." + String(Xtjexsws, "0"))) + Dbl_MoneyYb
If S2N(LrText(13).Tag) = 0 Then
Dbl_MoneyBb = S2N(Format((-1) * S2N(WglrGrid.TextMatrix(Rowjsq, Sydz("010", GridStr(), Szzls))) * S2N(LrText(13).Text), "####." + String(Xtjexsws, "0"))) + Dbl_MoneyBb
Else
Dbl_MoneyBb = S2N(Format((-1) * S2N(WglrGrid.TextMatrix(Rowjsq, Sydz("010", GridStr(), Szzls))) / S2N(LrText(13).Text), "####." + String(Xtjexsws, "0"))) + Dbl_MoneyBb
End If
End Select
Next Rowjsq
'如果总金额过大，提示重新录入
If Len(Trim(Str(Dbl_MoneyYb))) > 18 Or Len(Trim(Str(Dbl_MoneyBb))) > 18 Then
Tsxx = "单据总金额过大,请重新输入!"
Call Xtxxts(Tsxx, 0, 1)
Exit Function
End If
'二.=============如果以上有效性检查均顺利通过,则执行存盘动作============'
'对存盘进行事务处理(Fixed)
On Error GoTo Swcwcl
Cw_DataEnvi.DataConnect.BeginTrans
'判断单据状态以进行不同处理
'1.先对单据主表进行处理
If Trim(Lab_OperStatus) = "2" Then
'新增单据
'1.对于某些单据号自动生成的单据则可在此处自动生成
Select Case Me.InvoiceType '发票类型
Case 1, 3 '普通发票
BillCode = "1106"
Case 2, 4 '专用发票
BillCode = "1108"
Case 5 '红字普通
BillCode = "1107"
Case 6 '红字专用
BillCode = "1109"
End Select
Call Sub_ReadBillInfo(BillCode, Me, Var_Bill())
LrText(1).Text = CreatBillCode(BillCode, True)
'2.开始存盘
'打开单据主表动态集
If Rec_VouchMain.State = 1 Then Rec_VouchMain.Close
Rec_VouchMain.Open "Select * From Cg_InvoiceMain Where 1=2", Cw_DataEnvi.DataConnect, adOpenDynamic, adLockOptimistic
With Rec_VouchMain
.AddNew
.Fields("InvoiceMainID") = CreatBillID(BillCode) '单据ID
.Fields("InvoiceNum") = Trim(LrText(1).Text) '单据号
.Fields("InvoiceDate") = CDate(LrText(0).Text) '发票日期
.Fields("InvoiceNumZs") = Trim(LrText(2).Text) '原发票号
If Trim(LrText(3).Tag) <> "" Then
.Fields("InvoiceCode") = Trim(LrText(3).Tag) '发票类型编码
End If
If Trim(LrText(4).Tag) <> "" Then
.Fields("OrderFormMainID") = Trim(LrText(4).Tag) '订单ID
.Fields("OrderFormNum") = Trim(LrText(4).Text) '订单号
End If
If Trim(LrText(5).Tag) <> "" Then
.Fields("SupplierCode") = Trim(LrText(5).Tag) '供应商编码
End If
If Trim(LrText(6).Tag) <> "" Then
.Fields("PurTypeCode") = Trim(LrText(6).Tag) '采购类型编码
End If
If Trim(LrText(7).Tag) <> "" Then
.Fields("DeptCode") = Trim(LrText(7).Tag) '部门编码
End If
If Trim(LrText(8).Tag) <> "" Then
.Fields("PersonCode") = Trim(LrText(8).Tag) '业务员编码
End If
If Trim(LrText(9).Tag) <> "" Then
.Fields("SSCode") = Trim(LrText(9).Tag) '结算方式编码
End If
If Trim(LrText(10).Tag) <> "" Then
.Fields("PayCode") = Trim(LrText(10).Tag) '付款条件编码
End If
If Trim(LrText(11).Tag) <> "" Then
.Fields("TransferWayCode") = Trim(LrText(11).Tag) '运输方式编码
End If
If Trim(LrText(12).Tag) <> "" Then
.Fields("ForeignCurrCode") = Trim(LrText(12).Tag) '货币编码
End If
.Fields("AccRate") = S2N(LrText(13).Text) '汇率
If Trim(LrText(14).Tag) <> "" Then
.Fields("ChargeDept") = Trim(LrText(14).Tag) '费用单位编码
End If
Select Case Me.InvoiceType '发票类型
Case 1
.Fields("PeriodStarFlag") = 1 '期初标志
.Fields("InvoiceSort") = 0 '发票类别（0-普通，1-专用）
.Fields("InvoiceKind") = 0 '发票性质（0-蓝字，1-红字）
Case 2
.Fields("PeriodStarFlag") = 1 '期初标志
.Fields("InvoiceSort") = 1 '发票类别（0-普通，1-专用）
.Fields("InvoiceKind") = 0 '发票性质（0-蓝字，1-红字）
Case 3
.Fields("PeriodStarFlag") = 0 '期初标志
.Fields("InvoiceSort") = 0 '发票类别（0-普通，1-专用）
.Fields("InvoiceKind") = 0 '发票性质（0-蓝字，1-红字）
Case 4
.Fields("PeriodStarFlag") = 0 '期初标志
.Fields("InvoiceSort") = 1 '发票类别（0-普通，1-专用）
.Fields("InvoiceKind") = 0 '发票性质（0-蓝字，1-红字）
Case 5
.Fields("PeriodStarFlag") = 0 '期初标志
.Fields("InvoiceSort") = 0 '发票类别（0-普通，1-专用）
.Fields("InvoiceKind") = 1 '发票性质（0-蓝字，1-红字）
Case 6
.Fields("PeriodStarFlag") = 0 '期初标志
.Fields("InvoiceSort") = 1 '发票类别（0-普通，1-专用）
.Fields("InvoiceKind") = 1 '发票性质（0-蓝字，1-红字）
End Select
'现付标志
If Chk_Xf.Value Then
.Fields("InvoiceFlag") = 0
Else
.Fields("InvoiceFlag") = 1
End If
.Fields("Remark") = Trim(LrText(15).Text) '备注
.Fields("KjYear") = Int_Year '会计年
.Fields("Period") = Int_Period '会计期间
.Fields("Maker") = Trim(LrText(16).Text) '制单人
.Fields("Checker") = "" '审核人置空
.Fields("ApAccCode") = Fun_InputCodeSupplier(Trim(Me.LrText(5).Tag), 0) '应付科目
.Fields("NowValueFor") = Dbl_MoneyYb '发票总金额（原币）
.Fields("NowValue") = Dbl_MoneyBb '发票总金额（本币）
.Fields("ChalkitupMan") = "" '记帐人
.Update
'系统读出单据ID写入Lab_BillID
Lab_BillId.Caption = .Fields("InvoiceMainID")
End With
Else
'修改单据
'1.删除原单据子表中所有内容
Cw_DataEnvi.DataConnect.Execute ("Delete Cg_InvoiceSub Where InvoiceMainID=" & S2N(Lab_BillId.Caption))
'打开单据主表动态集
If Rec_VouchMain.State = 1 Then Rec_VouchMain.Close
Rec_VouchMain.Open "Select * From Cg_InvoiceMain Where InvoiceMainID=" & S2N(Lab_BillId.Caption), Cw_DataEnvi.DataConnect, adOpenDynamic, adLockOptimistic
With Rec_VouchMain
.Fields("InvoiceNum") = Trim(LrText(1).Text) '单据号
.Fields("InvoiceDate") = CDate(LrText(0).Text) '发票日期
.Fields("InvoiceNumZs") = Trim(LrText(2).Text) '原发票号
If Trim(LrText(3).Tag) <> "" Then
.Fields("InvoiceCode") = Trim(LrText(3).Tag) '发票类型编码
Else
.Fields("InvoiceCode") = Null
End If
If Trim(LrText(4).Tag) <> "" Then
.Fields("OrderFormMainID") = Trim(LrText(4).Tag) '订单ID
.Fields("OrderFormNum") = Trim(LrText(4).Text) '订单号
Else
.Fields("OrderFormMainID") = Null
.Fields("OrderFormNum") = Null
End If
If Trim(LrText(5).Tag) <> "" Then
.Fields("SupplierCode") = Trim(LrText(5).Tag) '供应商编码
Else
.Fields("SupplierCode") = Null
End If
If Trim(LrText(6).Tag) <> "" Then
.Fields("PurTypeCode") = Trim(LrText(6).Tag) '采购类型编码
Else
.Fields("PurTypeCode") = Null
End If
If Trim(LrText(7).Tag) <> "" Then
.Fields("DeptCode") = Trim(LrText(7).Tag) '部门编码
Else
.Fields("DeptCode") = Null
End If
If Trim(LrText(8).Tag) <> "" Then
.Fields("PersonCode") = Trim(LrText(8).Tag) '业务员编码
Else
.Fields("PersonCode") = Null
End If
If Trim(LrText(9).Tag) <> "" Then
.Fields("SSCode") = Trim(LrText(9).Tag) '计算方式
Else
.Fields("SSCode") = Null
End If
If Trim(LrText(10).Tag) <> "" Then
.Fields("PayCode") = Trim(LrText(10).Tag) '付款条件编码
Else
.Fields("PayCode") = Null
End If
If Trim(LrText(11).Tag) <> "" Then
.Fields("TransferWayCode") = Trim(LrText(11).Tag) '运输方式编码
Else
.Fields("TransferWayCode") = Null
End If
If Trim(LrText(12).Tag) <> "" Then
.Fields("ForeignCurrCode") = Trim(LrText(12).Tag) '货币编码
Else
.Fields("ForeignCurrCode") = Null
End If
.Fields("AccRate") = S2N(LrText(13).Text) '汇率
If Trim(LrText(14).Tag) <> "" Then
.Fields("ChargeDept") = Trim(LrText(14).Tag) '费用单位编码
Else
.Fields("ChargeDept") = Null
End If
Select Case Me.InvoiceType '发票类型
Case 1
.Fields("PeriodStarFlag") = 1 '期初标志
.Fields("InvoiceSort") = 0 '发票类别（0-普通，1-专用）
.Fields("InvoiceKind") = 0 '发票性质（0-蓝字，1-红字）
Case 2
.Fields("PeriodStarFlag") = 1 '期初标志
.Fields("InvoiceSort") = 1 '发票类别（0-普通，1-专用）
.Fields("InvoiceKind") = 0 '发票性质（0-蓝字，1-红字）
Case 3
.Fields("PeriodStarFlag") = 0 '期初标志
.Fields("InvoiceSort") = 0 '发票类别（0-普通，1-专用）
.Fields("InvoiceKind") = 0 '发票性质（0-蓝字，1-红字）
Case 4
.Fields("PeriodStarFlag") = 0 '期初标志
.Fields("InvoiceSort") = 1 '发票类别（0-普通，1-专用）
.Fields("InvoiceKind") = 0 '发票性质（0-蓝字，1-红字）
Case 5
.Fields("PeriodStarFlag") = 0 '期初标志
.Fields("InvoiceSort") = 0 '发票类别（0-普通，1-专用）
.Fields("InvoiceKind") = 1 '发票性质（0-蓝字，1-红字）
Case 6
.Fields("PeriodStarFlag") = 0 '期初标志
.Fields("InvoiceSort") = 1 '发票类别（0-普通，1-专用）
.Fields("InvoiceKind") = 1 '发票性质（0-蓝字，1-红字）
End Select
'现付标志
If Chk_Xf.Value Then
.Fields("InvoiceFlag") = 0
Else
.Fields("InvoiceFlag") = 1
End If
.Fields("Remark") = Trim(LrText(15).Text) '备注
.Fields("KjYear") = Int_Year '会计年
.Fields("Period") = Int_Period '会计期间
.Fields("Maker") = Trim(LrText(16).Text) '制单人
.Fields("Checker") = "" '审核人置空
.Fields("ApAccCode") = Fun_InputCodeSupplier(Trim(Me.LrText(5).Tag), 0) '应付科目
.Fields("NowValueFor") = Dbl_MoneyYb '发票总金额（原币）
.Fields("NowValue") = Dbl_MoneyBb '发票总金额（本币）
.Fields("ChalkitupMan") = "" '记帐人
.Update
End With
End If
'2.对单据子表进行处理
'打开单据子表动态集
If Rec_VouchSub.State = 1 Then Rec_VouchSub.Close
Rec_VouchSub.Open "Select * From Cg_InvoiceSub 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
Str_Temp = Trim(WglrGrid.TextMatrix(Rowjsq, Sydz("001", GridStr(), Szzls)))
With Rec_VouchSub
.AddNew
.Fields("PurAccCODE") = Fun_InputCodePurTax(Str_Temp, 0) '采购科目
.Fields("PurTaxAccCode") = Fun_InputCodePurTax(Str_Temp, 1) '采购税金科目
.Fields("InvoiceSubID") = Rowjsq - WglrGrid.FixedRows + 1 '单据记录顺序号
.Fields("InvoiceMainID") = S2N(Lab_BillId.Caption) '单据ID
.Fields("Mnumber") = Trim(WglrGrid.TextMatrix(Rowjsq, Sydz("001", GridStr(), Szzls))) '物料编码
If WglrGrid.ValueMatrix(Rowjsq, 3) = 1 Then '费用
.Fields("IsCharge") = 1
Else
.Fields("IsCharge") = 0
End If
Select Case Me.InvoiceType '发票类型
Case 1, 3 '蓝字普通发票
.Fields("Quantity") = S2N(WglrGrid.TextMatrix(Rowjsq, Sydz("005", GridStr(), Szzls))) '数量
.Fields("PriceYb") = S2N(WglrGrid.TextMatrix(Rowjsq, Sydz("006", GridStr(), Szzls))) '单价（原币）
.Fields("MoneyYb") = S2N(WglrGrid.TextMatrix(Rowjsq, Sydz("007", GridStr(), Szzls))) '金额（原币）
.Fields("TotalMoneyYb") = S2N(WglrGrid.TextMatrix(Rowjsq, Sydz("007", GridStr(), Szzls))) '价税合计（原币）
If S2N(LrText(13).Tag) = 0 Then
.Fields("PriceBb") = Format(S2N(WglrGrid.TextMatrix(Rowjsq, Sydz("006", GridStr(), Szzls))) * S2N(LrText(13).Text), "####." + String(Xtdjxsws, "0")) '单价（本币）
.Fields("MoneyBb") = Format(S2N(WglrGrid.TextMatrix(Rowjsq, Sydz("007", GridStr(), Szzls))) * S2N(LrText(13).Text), "####." + String(Xtjexsws, "0")) '金额（本币）
.Fields("TotalMoneyBb") = Format(S2N(WglrGrid.TextMatrix(Rowjsq, Sydz("007", GridStr(), Szzls))) * S2N(LrText(13).Text), "####." + String(Xtjexsws, "0")) '价税合计（本币）
Else
.Fields("PriceBb") = Format(S2N(WglrGrid.TextMatrix(Rowjsq, Sydz("006", GridStr(), Szzls))) / S2N(LrText(13).Text), "####." + String(Xtdjxsws, "0")) '单价（本币）
.Fields("MoneyBb") = Format(S2N(WglrGrid.TextMatrix(Rowjsq, Sydz("007", GridStr(), Szzls))) / S2N(LrText(13).Text), "####." + String(Xtjexsws, "0")) '金额（本币）
.Fields("TotalMoneyBb") = Format(S2N(WglrGrid.TextMatrix(Rowjsq, Sydz("007", GridStr(), Szzls))) / S2N(LrText(13).Text), "####." + String(Xtjexsws, "0")) '价税合计（本币）
End If
Case 2, 4 '蓝字专用发票
.Fields("TaxRate") = S2N(WglrGrid.TextMatrix(Rowjsq, Sydz("005", GridStr(), Szzls))) '税率
.Fields("Quantity") = S2N(WglrGrid.TextMatrix(Rowjsq, Sydz("006", GridStr(), Szzls))) '数量
.Fields("PriceYb") = S2N(WglrGrid.TextMatrix(Rowjsq, Sydz("007", GridStr(), Szzls))) '单价（原币）
.Fields("MoneyYb") = S2N(WglrGrid.TextMatrix(Rowjsq, Sydz("008", GridStr(), Szzls))) '金额（原币）
.Fields("TaxMoneyYb") = S2N(WglrGrid.TextMatrix(Rowjsq, Sydz("009", GridStr(), Szzls))) '税额（原币）
.Fields("TotalMoneyYb") = S2N(WglrGrid.TextMatrix(Rowjsq, Sydz("010", GridStr(), Szzls))) '价税合计（原币）
If S2N(LrText(13).Tag) = 0 Then
.Fields("PriceBb") = Format(S2N(WglrGrid.TextMatrix(Rowjsq, Sydz("007", GridStr(), Szzls))) * S2N(LrText(13).Text), "####." + String(Xtdjxsws, "0")) '单价（本币）
.Fields("MoneyBb") = Format(S2N(WglrGrid.TextMatrix(Rowjsq, Sydz("008", GridStr(), Szzls))) * S2N(LrText(13).Text), "####." + String(Xtjexsws, "0")) '金额（本币）
.Fields("TaxMoneyBb") = Format(S2N(WglrGrid.TextMatrix(Rowjsq, Sydz("009", GridStr(), Szzls))) * S2N(LrText(13).Text), "####." + String(Xtjexsws, "0")) '税额（本币）
.Fields("TotalMoneyBb") = Format(S2N(WglrGrid.TextMatrix(Rowjsq, Sydz("010", GridStr(), Szzls))) * S2N(LrText(13).Text), "####." + String(Xtjexsws, "0")) '价税合计（本币）
Else
.Fields("PriceBb") = Format(S2N(WglrGrid.TextMatrix(Rowjsq, Sydz("007", GridStr(), Szzls))) / S2N(LrText(13).Text), "####." + String(Xtdjxsws, "0")) '单价（本币）
.Fields("MoneyBb") = Format(S2N(WglrGrid.TextMatrix(Rowjsq, Sydz("008", GridStr(), Szzls))) / S2N(LrText(13).Text), "####." + String(Xtjexsws, "0")) '金额（本币）
.Fields("TaxMoneyBb") = Format(S2N(WglrGrid.TextMatrix(Rowjsq, Sydz("009", GridStr(), Szzls))) / S2N(LrText(13).Text), "####." + String(Xtjexsws, "0")) '税额（本币）
.Fields("TotalMoneyBb") = Format(S2N(WglrGrid.TextMatrix(Rowjsq, Sydz("010", GridStr(), Szzls))) / S2N(LrText(13).Text), "####." + String(Xtjexsws, "0")) '价税合计（本币）
End If
Case 5 '红字普通发票
.Fields("Quantity") = (-1) * S2N(WglrGrid.TextMatrix(Rowjsq, Sydz("005", GridStr(), Szzls))) '数量
.Fields("PriceYb") = S2N(WglrGrid.TextMatrix(Rowjsq, Sydz("006", GridStr(), Szzls))) '单价（原币）
.Fields("MoneyYb") = (-1) * S2N(WglrGrid.TextMatrix(Rowjsq, Sydz("007", GridStr(), Szzls))) '金额（原币）
.Fields("TotalMoneyYb") = (-1) * S2N(WglrGrid.TextMatrix(Rowjsq, Sydz("007", GridStr(), Szzls))) '价税合计（原币）
If S2N(LrText(13).Tag) = 0 Then
.Fields("PriceBb") = Format(S2N(WglrGrid.TextMatrix(Rowjsq, Sydz("006", GridStr(), Szzls))) * S2N(LrText(13).Text), "####." + String(Xtdjxsws, "0")) '单价（本币）
.Fields("MoneyBb") = Format((-1) * S2N(WglrGrid.TextMatrix(Rowjsq, Sydz("007", GridStr(), Szzls))) * S2N(LrText(13).Text), "####." + String(Xtjexsws, "0")) '金额（本币）
.Fields("TotalMoneyBb") = Format((-1) * S2N(WglrGrid.TextMatrix(Rowjsq, Sydz("007", GridStr(), Szzls))) * S2N(LrText(13).Text), "####." + String(Xtjexsws, "0")) '价税合计（本币）
Else
.Fields("PriceBb") = Format(S2N(WglrGrid.TextMatrix(Rowjsq, Sydz("006", GridStr(), Szzls))) / S2N(LrText(13).Text), "####." + String(Xtdjxsws, "0")) '单价（本币）
.Fields("MoneyBb") = Format((-1) * S2N(WglrGrid.TextMatrix(Rowjsq, Sydz("007", GridStr(), Szzls))) / S2N(LrText(13).Text), "####." + String(Xtjexsws, "0")) '金额（本币）
.Fields("TotalMoneyBb") = Format((-1) * S2N(WglrGrid.TextMatrix(Rowjsq, Sydz("007", GridStr(), Szzls))) / S2N(LrText(13).Text), "####." + String(Xtjexsws, "0")) '价税合计（本币）
End If
Case 6 '红字专用发票
.Fields("TaxRate") = S2N(WglrGrid.TextMatrix(Rowjsq, Sydz("005", GridStr(), Szzls))) '税率
.Fields("Quantity") = (-1) * S2N(WglrGrid.TextMatrix(Rowjsq, Sydz("006", GridStr(), Szzls))) '数量
.Fields("PriceYb") = S2N(WglrGrid.TextMatrix(Rowjsq, Sydz("007", GridStr(), Szzls))) '单价（原币）
.Fields("MoneyYb") = (-1) * S2N(WglrGrid.TextMatrix(Rowjsq, Sydz("008", GridStr(), Szzls))) '金额（原币）
.Fields("TaxMoneyYb") = (-1) * S2N(WglrGrid.TextMatrix(Rowjsq, Sydz("009", GridStr(), Szzls))) '税额（原币）
.Fields("TotalMoneyYb") = (-1) * S2N(WglrGrid.TextMatrix(Rowjsq, Sydz("010", GridStr(), Szzls))) '价税合计（原币）
If S2N(LrText(13).Tag) = 0 Then
.Fields("PriceBb") = Format(S2N(WglrGrid.TextMatrix(Rowjsq, Sydz("007", GridStr(), Szzls))) * S2N(LrText(13).Text), "####." + String(Xtdjxsws, "0")) '单价（本币）
.Fields("MoneyBb") = Format((-1) * S2N(WglrGrid.TextMatrix(Rowjsq, Sydz("008", GridStr(), Szzls))) * S2N(LrText(13).Text), "####." + String(Xtjexsws, "0")) '金额（本币）
.Fields("TaxMoneyBb") = Format((-1) * S2N(WglrGrid.TextMatrix(Rowjsq, Sydz("009", GridStr(), Szzls))) * S2N(LrText(13).Text), "####." + String(Xtjexsws, "0")) '税额（本币）
.Fields("TotalMoneyBb") = Format((-1) * S2N(WglrGrid.TextMatrix(Rowjsq, Sydz("010", GridStr(), Szzls))) * S2N(LrText(13).Text), "####." + String(Xtjexsws, "0")) '价税合计（本币）
Else
.Fields("PriceBb") = Format(S2N(WglrGrid.TextMatrix(Rowjsq, Sydz("007", GridStr(), Szzls))) / S2N(LrText(13).Text), "####." + String(Xtdjxsws, "0")) '单价（本币）
.Fields("MoneyBb") = Format((-1) * S2N(WglrGrid.TextMatrix(Rowjsq, Sydz("008", GridStr(), Szzls))) / S2N(LrText(13).Text), "####." + String(Xtjexsws, "0")) '金额（本币）
.Fields("TaxMoneyBb") = Format((-1) * S2N(WglrGrid.TextMatrix(Rowjsq, Sydz("009", GridStr(), Szzls))) / S2N(LrText(13).Text), "####." + String(Xtjexsws, "0")) '税额（本币）
.Fields("TotalMoneyBb") = Format((-1) * S2N(WglrGrid.TextMatrix(Rowjsq, Sydz("010", GridStr(), Szzls))) / S2N(LrText(13).Text), "####." + String(Xtjexsws, "0")) '价税合计（本币）
End If
End Select
.Update
End With
Next Rowjsq
'生成最新成本
Cw_DataEnvi.DataConnect.Execute ("CG_Sp_ForNewInCost " & S2N(Lab_BillId.Caption))
Cw_DataEnvi.DataConnect.CommitTrans
Sub_SaveBill = True
Tsxx = "单据存盘完毕! 单据号:" & Trim(LrText(1).Text)
Call Xtxxts(Tsxx, 0, 4)
'标识单据发生改动
Bln_BillChange = True
'设置单据改变后的状态
Lab_OperStatus = "1"
Call Sub_OperStatus("10")
Rec_Query.Requery
Rec_Query.Find "InvoiceMainID=" & S2N(Lab_BillId.Caption)
Exit Function
Swcwcl: '数据存盘时出现错误
Cw_DataEnvi.DataConnect.RollbackTrans
With WglrGrid
If Err.Number = -2147217887 Then
Tsxx = "单据中第 " & Trim(Str(Rowjsq - .FixedRows + 1)) & " 条分录录入数据超出允许范围!"
Call Xtxxts(Tsxx, 0, 1)
Changelock = True
.Select Rowjsq, Qslz
WglrGrid.SetFocus
Changelock = False
Exit Function
Else
Tsxx = "存盘过程中出现未知错误,程序自动恢复保存前状态!"
Call Xtxxts(Tsxx, 0, 1)
Exit Function
End If
End With
Lrcwcl: '录入错误处理(存盘前逐行有效性判断)
With WglrGrid
Call Xtxxts("(第 " & Trim(Str(Rowjsq - .FixedRows + 1)) & " 条单据分录)-" & Tsxx, 0, 1)
Changelock = True
.Select Rowjsq, Lrywlz
WglrGrid.SetFocus
Changelock = False
Exit Function
End With
End Function
'选择首张,上张,下张,末张(此4个过程只需用您的单据ID字段名替换"InvoiceMainID"即可)
Private Sub Sub_First() '首张
With Rec_Query
If .RecordCount = 0 Then
Exit Sub
End If
.MoveFirst
Lab_BillId.Caption = .Fields("InvoiceMainID")
Call Sub_ShowBill
End With
End Sub
Private Sub Sub_Prev() '上张
With Rec_Query
If .RecordCount = 0 Then
Exit Sub
End If
If Not .BOF Then
.MovePrevious
End If
If Not .BOF Then
Lab_BillId.Caption = .Fields("InvoiceMainID")
Else
.MoveNext
End If
Call Sub_ShowBill
End With
End Sub
Private Sub Sub_Next() '下张
With Rec_Query
If .RecordCount = 0 Then
Exit Sub
End If
If Not .EOF Then
.MoveNext
End If
If Not .EOF Then
Lab_BillId.Caption = .Fields("InvoiceMainID")
Else
.MovePrevious
End If
Call Sub_ShowBill
End With
End Sub
Private Sub Sub_Last() '末张
With Rec_Query
If .RecordCount = 0 Then
Exit Sub
End If
.MoveLast
Lab_BillId.Caption = .Fields("InvoiceMainID")
Call Sub_ShowBill
End With
End Sub
'[>>===================以下为根据实际业务需要自定义过程区域=============================<<]
'审核,弃审
Private Sub Sub_CheckBill() '审核
'判断用户是否有此功能执行权限,如有则写上机日志(进入)
If Not Security_Log(Str_RightCheck, Xtczybm, 1) Then
Exit Sub
End If
'[>>
'此处可以写入禁止单据审核的理由
'<<]
On Error GoTo Err_Execute
Cw_DataEnvi.DataConnect.BeginTrans
'将单据写入审核标识
Cw_DataEnvi.DataConnect.Execute ("Update Cg_InvoiceMain Set Checker='" & Xtczy & "' Where InvoiceMainID=" & S2N(Lab_BillId.Caption))
'回写订单和供应商
Cw_DataEnvi.DataConnect.Execute ("Cg_sp_InvoiceAssociateOrderFormAndSupplier " & S2N(Lab_BillId.Caption))
Cw_DataEnvi.DataConnect.CommitTrans
'写入系统操作员
LrText(17).Text = Xtczy
'设置审核弃审按钮状态
Call Sub_CheckStatus
'标识单据发生变化
Bln_BillChange = True
Exit Sub
Err_Execute:
Cw_DataEnvi.DataConnect.RollbackTrans
Tsxx = "审核过程出现错误，恢复到审核前状态!"
Call Xtxxts(Tsxx, 0, 4)
Exit Sub
End Sub
Private Sub Sub_AbandonCheck() '弃审
'判断用户是否有此功能执行权限,如有则写上机日志(进入)
If Not Security_Log(Str_RightCheck, Xtczybm, 1) Then
Exit Sub
End If
'[>>
Dim rst_Temp As New ADODB.Recordset
Set rst_Temp = Cw_DataEnvi.DataConnect.Execute("select ChalkitupMan,ApbookFlag from Cg_InvoiceMain where InvoiceMainID=" & S2N(Lab_BillId.Caption))
If rst_Temp.RecordCount <> 0 Then
If Trim("" & rst_Temp.Fields("ChalkitupMan").Value) <> "" Then
Tsxx = "该单据已结账,不允许弃审!"
Call Xtxxts(Tsxx, 0, 4)
Exit Sub
End If
If rst_Temp.Fields("ApbookFlag") Then
Tsxx = "该单据已被应付系统使用,不允许弃审!"
Call Xtxxts(Tsxx, 0, 4)
Exit Sub
End If
Else
Tsxx = "该单据已不存在!"
Call Xtxxts(Tsxx, 0, 4)
Exit Sub
End If
rst_Temp.Close
Set rst_Temp = Nothing
'此处可以写入禁止单据弃审的理由
'<<]
On Error GoTo Err_Execute
Cw_DataEnvi.DataConnect.BeginTrans
'将单据清除审核标识
Cw_DataEnvi.DataConnect.Execute ("Update Cg_InvoiceMain Set Checker='' Where InvoiceMainID=" & S2N(Lab_BillId.Caption))
'回写订单和供应商
Cw_DataEnvi.DataConnect.Execute ("Cg_sp_InvoiceAssociateOrderFormAndSupplier " & S2N(Lab_BillId.Caption) & ",1")
Cw_DataEnvi.DataConnect.CommitTrans
'清空单据审核人
LrText(17).Text = ""
'设置审核弃审按钮状态
Call Sub_CheckStatus
'标识单据发生变化
Bln_BillChange = True
Exit Sub
Err_Execute:
Cw_DataEnvi.DataConnect.RollbackTrans
Tsxx = "弃审过程出现错误，恢复到弃审前状态!"
Call Xtxxts(Tsxx, 0, 4)
Exit Sub
End Sub
Private Function Fun_AllowEdit() As Boolean '判断当前单据是否允许编辑或删除
Dim RecTemp As New ADODB.Recordset '临时使用动态集
Fun_AllowEdit = False
Sqlstr = "Select Checker ,ltrim(rtrim(isnull(ChalkitupMan,''))) as ChalkitupMan ,BanlanceDate From Cg_InvoiceMain Where InvoiceMainID=" & S2N(Lab_BillId.Caption)
Set RecTemp = Cw_DataEnvi.DataConnect.Execute(Sqlstr)
With RecTemp
If Not .EOF Then
If Trim(.Fields("Checker") & "") <> "" Then
Tsxx = "该单据已审核确认,不能修改或删除!"
Call Xtxxts(Tsxx, 0, 4)
Exit Function
End If
If Trim("" & .Fields("BanlanceDate")) <> "" Then
Tsxx = "该单据已结算,不能修改或删除!"
Call Xtxxts(Tsxx, 0, 4)
Exit Function
End If
If Trim(.Fields("ChalkitupMan") & "") <> "" Then
Tsxx = "该单据已结账,不能修改或删除!"
Call Xtxxts(Tsxx, 0, 4)
Exit Function
End If
End If
End With
Fun_AllowEdit = True
End Function
Public Property Get InvoiceType() As Integer
''''''以下为定义发票类型属性
'1.期初普通
'2 期初增值税
'3.普通蓝字
'4 增值税蓝字
'5.普通红字
'6 增值税红字
InvoiceType = Int_InvoiceType
End Property
Public Property Let InvoiceType(ByVal vNewValue As Integer)
Int_InvoiceType = vNewValue
End Property
'[>>===================以上为根据实际业务需要自定义过程区域=============================<<]
'===================以下程序为通用部分 ,一般不需更改(程序动作部分)======================='
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
End If
'判断是否有辅助行和录入行,如没有则加行
Do While .TextMatrix(.Rows - 1 - Fzxwghs, 0) = "*"
.AddItem ""
.RowHeight(.Rows - 1) = Sjhgd
Loop
End With
End Sub
Private Sub Lrzdbz() '录入字段帮助
If Not Ydcommand.Visible Then
Exit Sub
End If
With WglrGrid
Valilock = True
'处理通用部分
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
Valilock = False
If Ydtext.Visible Then
Ydtext.SetFocus
End If
End With
End Sub
Private Sub Cshhjwg() '初始化合计网格(*对合计网格来说,录入网格为容器)
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
'程序自动调整网格高度(自动设置为网格剩余高度+辅助项网格行数(默认为1)*数据行高度)、并设置其位置信息
.Height = Fzxwghs * Sjhgd + ((WglrGrid.Height - WglrGrid.FixedRows * WglrGrid.RowHeight(0)) Mod Sjhgd)
.RowHeight(0) = .Height
.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
'[>>
'此处可以填写显示与此网格行相关信息
'<<]
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
Call TextChangeLimit(Ydtext, GridInt(.Col, 1)) '去掉无效字符
Select Case GridInt(.Col, 1)
Case 8, 11 '金额型
Call Sjgskz(Ydtext, Xtjezws - Xtjexsws - 1, Xtjexsws)
Case 9, 12 '数量型
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 Not Fun_AllowInput 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
On Error Resume Next
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 Function Fun_AllowInput() As Boolean '当某种条件成立时禁止文本框激活使单据处于录入状态
'如果单据操作状态为浏览状态则不能显示录入载体(通用)
If Trim(Lab_OperStatus.Caption) = "1" Then
Exit Function
End If
'[>>
'此处可以填写禁止文本框激活使单据处于录入状态的理由
'<<]
Fun_AllowInput = True
End Function
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 vbKeyF2 '按F2键参照
Call xswbk
Call Lrzdbz
Case vbKeyDelete '删行
Call Scdqfl
Case vbKeyInsert '增行
Call zjlrfl
End Select
End Sub
Private Sub WglrGrid_KeyPress(KeyAscii As Integer) '网格接受键盘录入
'当某种条件成立时禁止文本框激活使单据处于录入状态
If Not Fun_AllowInput Then
Exit Sub
End If
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 '用户输入KeyAscii为0-32的键如空格
'显示录入载体
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
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 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)) Then
Exit Sub
End If
With WglrGrid
Hjjg = 0
For jsqte = .FixedRows To .Rows - 1
If .TextMatrix(jsqte, 0) = "*" Then
Hjjg = Hjjg + S2N(.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 S2N(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 And .Col >= .FixedCols 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 Wbklrwbcl(Index As Integer) '文本框录入事后处理程序
'以下为依据实际情况自定义部分[
Dim int_temp As Integer
Dim Str_Temp As String
Dim int_Row As Integer
Dim rst_Temp As New ADODB.Recordset
Dim str_sqlTemp As String
'以下为依据实际情况自定义部分[
TextChangeLock = True
Select Case Index
Case 4 '订单号
If Trim(LrText(4).Tag) <> "" Then
str_sqlTemp = "SELECT OrderFormMainID, OrderFormNum, SupplierCode,DeptCode, PersonCode, SSCode, " & _
" PayCode, TransferWayCode, ForeignCurrCode, AccRate, TaxRate, Payname, " & _
" OrderTypeName, SSName, SupplierName, DeptName, PersonName, " & _
" ForeignCurrName, ConVertFlag, TransferWayName, MNumber, MName, Model, " & _
" PurUnitName , Cess ,IsCharge " & _
" FROM Cg_V_OrderForm where " & _
" OrderFormMainID = " & S2N(LrText(Index).Tag)
Set rst_Temp = Cw_DataEnvi.DataConnect.Execute(str_sqlTemp)
If rst_Temp.RecordCount <> 0 Then
LrText(5).Tag = Trim("" & rst_Temp.Fields("SupplierCode"))
LrText(5).Text = Trim("" & rst_Temp.Fields("SupplierName"))
LrText(7).Tag = Trim("" & rst_Temp.Fields("DeptCode"))
LrText(7).Text = Trim("" & rst_Temp.Fields("DeptName"))
LrText(8).Tag = Trim("" & rst_Temp.Fields("PersonCode"))
LrText(8).Text = Trim("" & rst_Temp.Fields("PersonName"))
LrText(9).Tag = Trim("" & rst_Temp.Fields("SSCode"))
LrText(9).Text = Trim("" & rst_Temp.Fields("SSName"))
LrText(10).Tag = Trim("" & rst_Temp.Fields("PayCode"))
LrText(10).Text = Trim("" & rst_Temp.Fields("Payname"))
LrText(11).Tag = Trim("" & rst_Temp.Fields("TransferWayCode"))
LrText(11).Text = Trim("" & rst_Temp.Fields("TransferWayName"))
LrText(12).Tag = Trim("" & rst_Temp.Fields("ForeignCurrCode"))
LrText(12).Text = Trim("" & rst_Temp.Fields("ForeignCurrName"))
LrText(13).Text = Format(Trim(rst_Temp.Fields("AccRate") & ""), "###0." + String(4, "0"))
LrText(13).Tag = IIf(IsNull(rst_Temp.Fields("ConVertFlag")), 0, rst_Temp.Fields("ConVertFlag")) '外币的乘与除 1为乘，0为除
With WglrGrid
.Clear 1
For int_temp = .FixedRows To .Rows - 1
If Trim(.TextMatrix(int_temp, 0)) <> "*" Then
int_Row = int_temp
Exit For
End If
Next int_temp
rst_Temp.MoveFirst
For int_temp = int_Row To rst_Temp.RecordCount + int_Row - 1
If int_temp >= .Rows Then
.AddItem ""
.RowHeight(int_temp) = Sjhgd
End If
.TextMatrix(int_temp, 0) = "*"
.TextMatrix(int_temp, 3) = IIf(rst_Temp.Fields("IsCharge") = True, 1, 0)
.TextMatrix(int_temp, Sydz("001", GridStr(), Szzls)) = Trim("" & rst_Temp.Fields("Mnumber"))
.TextMatrix(int_temp, Sydz("002", GridStr(), Szzls)) = Trim("" & rst_Temp.Fields("Mname"))
.TextMatrix(int_temp, Sydz("003", GridStr(), Szzls)) = Trim("" & rst_Temp.Fields("model"))
.TextMatrix(int_temp, Sydz("004", GridStr(), Szzls)) = Trim("" & rst_Temp.Fields("PurUnitName"))
Select Case Me.InvoiceType '发票类型
Case 2, 4, 6 '专用发票
.TextMatrix(int_temp, Sydz("005", GridStr(), Szzls)) = rst_Temp.Fields("Cess")
End Select
rst_Temp.MoveNext
Next int_temp
End With
Call Sub_AdjustGrid
End If
rst_Temp.Close
Set rst_Temp = Nothing
End If
Case 12 '货币
If Trim(LrText(12).Tag) <> "" Then
str_sqlTemp = "SELECT ForeignCurrCode, ForeignCurrName, ConVertFlag, AccRate" & _
" From Gy_ForeignCurrency where " & _
" ForeignCurrCode = '" & Trim(LrText(Index).Tag) & "'"
Set rst_Temp = Cw_DataEnvi.DataConnect.Execute(str_sqlTemp)
If rst_Temp.RecordCount <> 0 Then
LrText(13).Text = Format(Trim(rst_Temp.Fields("AccRate") & ""), "###0." + String(4, "0"))
LrText(13).Tag = IIf(rst_Temp.Fields("ConVertFlag").Value = False, 0, 1)
End If
rst_Temp.Close
Set rst_Temp = Nothing
Else
LrText(13).Text = ""
LrText(13).Tag = ""
End If
End Select
TextChangeLock = False
']以上为依据实际情况自定义部分
'计算合计数据(Fixed)
Dim jsqte As Long '临时计数器
For jsqte = Qslz To WglrGrid.Cols - 1
Call Sjhj(jsqte)
Next jsqte
End Sub
Private Sub LrText_Change(Index As Integer)
'屏蔽程序改变控制
If TextChangeLock Then
Exit Sub
End If
TextValiJudgeLock(Index) = False '打开有效性判断锁
'限制字段录入长度
TextChangeLock = True '加锁(防止执行Lrtext_Change)
Call TextChangeLimit(LrText(Index), Textint(Index, 1)) '去掉无效字符
Select Case Textint(Index, 1)
Case 8, 11 '金额型
Call Sjgskz(LrText(Index), Xtjezws - Xtjexsws - 1, Xtjexsws)
Case 9, 12 '数量型
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
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() '录入文本框初始化
Dim Int_TabIndex As Integer 'Tab焦点计数器
'单据录入中文本框焦点由0开始
LrText(0).TabIndex = 0
'最大录入文本框索引值
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
'自动装入录入文本框和其解释标签
If jsqte <> 0 Then
Load LrText(jsqte)
Load TsLabel(jsqte)
'判断录入文本框是否显示
If Textboolean(jsqte, 4) Then
LrText(jsqte).Visible = True
TsLabel(jsqte).Visible = True
End If
'判断文本框是否可编辑
If Textboolean(jsqte, 5) Then
LrText(jsqte).Enabled = True
Else
LrText(jsqte).Enabled = False
End If
End If
'初始化其内容
TextChangeLock = True
LrText(jsqte).Text = ""
LrText(jsqte).Tag = ""
LrText(jsqte).MaxLength = Textint(jsqte, 5)
TextChangeLock = False
'设置文本框位置及大小,并设置相应标签内容及其位置
LrText(jsqte).Move Textint(jsqte, 13), Textint(jsqte, 12), Textint(jsqte, 11), Textint(jsqte, 10)
TsLabel(jsqte).Caption = Textstr(jsqte, 7) & ":"
TsLabel(jsqte).Move Textint(jsqte, 13) - TsLabel(jsqte).Width - 20, Textint(jsqte, 12) + (Textint(jsqte, 10) - TsLabel(jsqte).Height) / 2 - 30
End If
'将文本框有效性判断进行加锁,在文本框内容发生变化时将锁打开
TextValiJudgeLock(jsqte) = True
Next jsqte
'设置文本框焦点转移顺序(前提文本焦点从0至Max_Text_Index)
For Int_TabIndex = 0 To Max_Text_Index
For jsqte = 0 To Max_Text_Index
If Textint(jsqte, 14) = Int_TabIndex Then
LrText(jsqte).TabIndex = Int_TabIndex
End If
Next jsqte
Next Int_TabIndex
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
'文本框内容为空认为有效,并清空其Tag值
If Trim(LrText(Index)) = "" Then
LrText(Index).Tag = ""
Call Wbklrwbcl(Index)
Ydcommand1.Visible = False
TextValiJudgeLock(Index) = True
TextYxxpd = True
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)
LrText(Index).SetFocus
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
Case 2 '日期型
If IsDate(LrText(Index).Text) Then
LrText(Index).Text = Format(LrText(Index).Text, "yyyy-mm-dd")
If S2N(Mid(LrText(Index), 1, 4)) < 1900 Then
LrText(Index).Text = "1900" + Mid(LrText(Index), 5, 6)
End If
Else
Tsxx = "非法公历日期!(格式:" + Format(Date, "yyyy-mm-dd") + ")"
Call Xtxxts(Tsxx, 0, 1)
LrText(Index).SetFocus
Exit Function
End If
Case 3 '其他类型
End Select
'隐藏帮助按钮
Ydcommand1.Visible = False
'如果有效则加锁,用户不改变内容则不再进行有效性判断
TextValiJudgeLock(Index) = True
'调用文本框事后处理程序
Call Wbklrwbcl(Index)
'有效性判断通过则返回True
TextYxxpd = True
End Function