📄 frmlisttrans.frm
字号:
strSql = "SELECT Voucher.* FROM Voucher,TransVoucher Where Voucher.lngVoucherSourceID=16 And Voucher.lngSourceVoucherID=" & lngTransVoucherID & " And TransVoucher.lngTransVoucherID=" & lngTransVoucherID & " And Voucher.intyear=" & intYear & " ORDER BY Voucher.lngVoucherID DESC"
End Select
Set recTemp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
If recTemp.BOF And recTemp.EOF Then
intYear_Last = 0
bytPeriod_Last = 0
lngVoucherID = 0
Else
recTemp.MoveFirst
intYear_Last = recTemp("intYear")
bytPeriod_Last = recTemp("bytPeriod")
lngVoucherID = recTemp("lngVoucherID")
intLastVoucherNo = recTemp("intVoucherNo")
colVoucherNo.Add recTemp("intVoucherNO").Value, Trim(str(lngTransVoucherID))
End If
Set recTemp = Nothing
blnExisted = False
Select Case strFrequency
Case ""
blnExisted = False
Case "期"
If (intYear = intYear_Last) And (bytPeriod = bytPeriod_Last) Then
blnExisted = True
End If
Case "年"
If intYear = intYear_Last Then
blnExisted = True
End If
End Select
'最新生成的凭证是否在strFrequency指定的期间内
If blnExisted Then
'规则：
'1)凭证未复核：直接覆盖
'1)凭证已复核：提示不能再生成转帐凭证
'2)凭证已记帐：提示是否生成冲销凭证
If mclsVoucherMethod.GetVoucherStatus(lngVoucherID) = False Then Exit Sub
If mclsVoucherMethod.IsPosted Then
''' strMsg = "“" & strTransVoucherName & "”转帐周期为每" & strFrequency & "一次，本" & strFrequency & "已转帐并已记帐，是否冲销已记帐的" & """" & strTransVoucherName & """" & "凭证，再生成新的" & """" & strTransVoucherName & """" & "凭证？"
''' If ShowMsg(Me.hwnd, strMsg, MB_YESNO + MB_ICONQUESTION + MB_DEFBUTTON2 + MB_SYSTEMMODAL, "提示信息") <> IDYES Then
''' '将取消选中状态：√
''' .TextMatrix(i, 1) = ""
''' intNot = intNot + 1
''' Else
''' '生成冲销凭证
''' arrGenCancel(i) = lngVoucherID
'''
''' End If
strMsg = "”" & strTransVoucherName & "”转帐周期为每" & strFrequency & "一次，本" & strFrequency & "已转帐并记帐，不能再生成转帐凭证！"
'将取消选中状态：√
.TextMatrix(i, 1) = ""
intNot = intNot + 1
cMsgBox strMsg, "通用转帐"
Else
If mclsVoucherMethod.IsChecked Then
strMsg = "”" & strTransVoucherName & "”转帐周期为每" & strFrequency & "一次，本" & strFrequency & "已转帐并复核，不能再生成转帐凭证！"
'将取消选中状态：√
.TextMatrix(i, 1) = ""
intNot = intNot + 1
cMsgBox strMsg, "通用转帐"
Else
'将已生成转帐凭证删除，以便重新生成达到覆盖的目的
arrDelVoucher(i) = lngVoucherID
colDelVoucherNo.Add intLastVoucherNo, Trim(str(lngTransVoucherID))
End If
End If
End If '//If blnExiste
End If
Next i
End With
If (Not blnFound) Or intChoose = intNot Then Exit Sub
If ShowMsg(Me.hwnd, "您确定要执行转帐吗？", MB_YESNO + MB_ICONQUESTION + MB_DEFBUTTON2 + MB_SYSTEMMODAL, "提示信息") <> IDYES Then Exit Sub
On Error GoTo DoTransErr
MsgForm.PleaseWait "正在执行转帐,请稍候．．．"
strSql = "Select strAccountCode,lngAccountID From Account"
Set recTemp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
Set mcolAccount = New Collection
With recTemp
Do While Not .EOF
mcolAccount.Add CStr(!strAccountCode), CStr(!lngAccountID)
.MoveNext
Loop
End With
Set recTemp = Nothing
gclsBase.BaseWorkSpace.BeginTrans
mintCount = 0
intOk = 0
intErr = 0
'生成冲销凭证
For i = 1 To UBound(arrGenCancel)
If arrGenCancel(i) <> 0 Then
If mclsVoucherMethod.GenCancelVoucher(arrGenCancel(i), , True, True) = False Then
GoTo DoTransErr
End If
End If
Next i
ReDim arrGenCancel(0)
'删除凭证
For i = 1 To UBound(arrDelVoucher)
If arrDelVoucher(i) <> 0 Then
If mclsVoucherMethod.DeleteVoucher(arrDelVoucher(i), True) = False Then
GoTo DoTransErr
End If
End If
Next i
ReDim arrDelVoucher(0)
'第 二 步：调用转帐公式将转帐结果存入动态数组
Screen.MousePointer = vbHourglass
For ChooseRow = 1 To grdList.Rows - 1
'** IF 选择标志为"√" **
If grdList.TextMatrix(ChooseRow, 1) = "√" Then
lngTransVoucherID = CLng(grdList.TextMatrix(ChooseRow, 0))
If Not TransVoucher(lngTransVoucherID) Then
If intChoose = 1 Then
GoTo DoTransErr
End If
End If
'第 三 步：将动态数组中生成的数据生成转帐凭证
'------------------------------------------------------------------------------------------------
'--------------------------------- 生成转帐凭证 -----------------------------------------
'1)取出动态数组中的数据
'** IF所有分录的数据均为零且只选择了一张凭证 **
If ArrIsEmpty(mlngAccountID) And intChoose = 1 Then
Unload MsgForm
ShowMsg Me.hwnd, "所有分录的数据均为零，本次转帐未完成!", vbOKOnly, App.title
Screen.MousePointer = vbDefault
gclsBase.BaseWorkSpace.RollBacktrans
Exit Sub
'** ELSE OF IF所有分录的数据均为零且只选择了一张凭证 **
Else
'** IF 可以生成凭证 **
If Not ArrIsEmpty(mlngAccountID) Then
intOk = intOk + 1
lngTransVoucherID = 0
lngVoucherID = 0
lngAccountID_Temp = 0
'循环的步骤
'（1-2）--》（2）--》（1-1）生成完整的一张凭证
'
blnLoopEnd = False
For intArrNo = 1 To UBound(mlngAccountID)
'** IF (1) **
If lngTransVoucherID <> mlngTransID(intArrNo) Then '转帐模板ID发生变化，生成新的凭证
GenTransIn:
'（1-1） 追加已生成的凭证的转入科目部分
'------------------------------------------------Begin----------------------------------------------------------
If lngVoucherID <> 0 Then '第一次进入循环时，不执行。所以保证执行此 IF/END IF 中的代码时是在生成某张凭证之后
blnOneIn = False
If UBound(arrlngAccountid_IN) = 0 Or (UBound(arrlngAccountid_IN) > 0 And arrlngAccountid_IN(0) = 0) Then
blnOneIn = True
End If
If blnOneIn Then '表明本张转帐模板仅有一条转入科目
strSql = "SELECT TransVoucherDetail.* FROM TransVoucherDetail" _
& " WHERE (((TransVoucherDetail.lngTransVoucherID)=" & mlngTransID(intArrNo - 1) & ") AND ((TransVoucherDetail.intTransDirection)=1))"
Set recTemp_1 = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
If recTemp_1.BOF And recTemp_1.EOF Then
GoTo DoTransErr
End If
dblSumAmount_D = 0
dblSumCurrency_D = 0
dblSumQuantity_D = 0
dblSumAmount_J = 0
dblSumCurrency_J = 0
dblSumQuantity_J = 0
For i = 0 To UBound(arrdblSumAmount) - 1
'统计所有的贷方
If arrintDirection(i) = -1 Then
dblSumAmount_D = dblSumAmount_D + arrdblSumAmount(i)
dblSumCurrency_D = dblSumCurrency_D + arrdblSumCurrency(i)
dblSumQuantity_D = dblSumQuantity_D + arrdblSumQuantity(i)
'统计所有的借方
Else
dblSumAmount_J = dblSumAmount_J + arrdblSumAmount(i)
dblSumCurrency_J = dblSumCurrency_J + arrdblSumCurrency(i)
dblSumQuantity_J = dblSumQuantity_J + arrdblSumQuantity(i)
End If
Next i
'通过转入科目的借贷方向计算转入科目的数值
If recTemp_1!intDirection = 1 Then
dblSumAmount = (dblSumAmount_D - dblSumAmount_J)
dblSumCurrency = (dblSumCurrency_D - dblSumCurrency_J)
dblSumQuantity = (dblSumQuantity_D - dblSumQuantity_J)
Else
dblSumAmount = (dblSumAmount_J - dblSumAmount_D)
dblSumCurrency = (dblSumCurrency_J - dblSumCurrency_D)
dblSumQuantity = (dblSumQuantity_J - dblSumQuantity_D)
End If
If dblSumAmount <> 0 Then
'如果没有数量核算
If Not gclsBase.ItemOfAccount(recTemp_1!lngAccountID) Then
dblSumQuantity = 0
End If
Dim dblRate As Double, rstRate As rdoResultset
If recTemp_1!lngCurrencyID > 1 Then
strSql = "Select * From Currencys,Rate Where Currencys.lngCurrencyID=Rate.lngCurrencyID And Currencys.lngCurrencyID=" & recTemp_1!lngCurrencyID
Set rstRate = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
With rstRate
If Not .EOF Then
.MoveLast
If !blnIsIndirect Then
If !dblRate <> 0 Then
dblSumCurrency = dblSumAmount / !dblRate
End If
Else
dblSumCurrency = dblSumAmount * !dblRate
End If
dblRate = !dblRate
Else
If dblSumCurrency <> 0 Then
dblRate = Abs(dblSumAmount / dblSumCurrency)
End If
End If
End With
Set rstRate = Nothing
Else
dblRate = 1
dblSumCurrency = dblSumAmount
End If
With recTemp
.AddNew
!lngVoucherID = lngVoucherID
!lngVoucherDetailID = BillPublic.GetNewID("VoucherDetail")
!strRemark = recTemp_1!strRemark
!lngAccountID = recTemp_1!lngAccountID
!intDirection = recTemp_1!intDirection
AddAccount recTemp_1!lngAccountID, recTemp_1!intDirection
!dblAmount = dblSumAmount
!lngCurrencyID = recTemp_1!lngCurrencyID
!dblCurrencyAmount = dblSumCurrency
If mcolRateDirect(recTemp_1!lngCurrencyID) Then
If dblSumAmount <> 0 Then
!dblRate = Abs(dblSumCurrency / dblSumAmount)
End If
Else
If dblSumCurrency <> 0 Then
!dblRate = Abs(dblSumAmount / dblSumCurrency)
End If
End If
!dblQuantity = dblSumQuantity
If dblSumQuantity <> 0 Then
!dblPrice = Abs(dblSumCurrency / dblSumQuantity)
Else
!dblPrice = 0
End If
!lngClassID1 = recTemp_1!lngClassID1
!lngClassID2 = recTemp_1!lngClassID2
'''!lngJobID = recTemp_1!lngJobID
!lngCustomerID = recTemp_1!lngCustomerID
!lngDepartmentID = recTemp_1!lngDepartmentID
!lngEmployeeID = recTemp_1!lngEmployeeID
lngVoucherDetailID = !lngVoucherDetailID
.Update
'修改科目发生额及余额
If ChangeAllAccount_from_Voucher("I", lngVoucherID) = False Then
GoTo DoTransErr
End If
EditVoucherOrder (lngVoucherID)
End With
Set recTemp_1 = Nothing
End If
Else '本条转帐模板有多条转入科目（既转入科目为非末级科目）
'在这种情况下，转入科目的借贷方向和转出科目的借贷方向刚好相反
strSql = "SELECT TransVoucherDetail.* FROM TransVoucherDetail" _
& " WHERE (((TransVoucherDetail.lngTransVoucherID)=" & lngTransVoucherID & ") AND ((TransVoucherDetail.intTransDirection)=1))"
Set recTemp_1 = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
If recTemp_1.BOF And recTemp_1.EOF Then
GoTo DoTransErr
End If
For i = 0 To UBound(arrlngAccountID) - 1
'查找某条转出科目对应的转入科目
blnFound = False
For j = 0 To UBound(arrlngAccountID_OUT)
If arrlngAccountID(i) = arrlngAccountID_OUT(j) Then
blnFound = True
intCount = j
End If
Next j
If blnFound = False Then
GoTo DoTransErr
End If
If arrdblSumAmount(i) <> 0 Then
With recTemp
.AddNew
!lngVoucherID = lngVoucherID
!lngRowID = intRow
intRow = intRow + 1
!strRemark = recTemp_1!strRemark
!lngAccountID = arrlngAccountid_IN(intCount) '!!!注意
!intDirection = recTemp_1!intDirection
AddAccount arrlngAccountid_IN(intCount), recTemp_1!intDirection
!dblAmount = arrdblSumAmount(i) '!!!注意
!lngCurrencyID = recTemp_1!lngCurrencyID
!dblCurrencyAmount = arrdblSumCurrency(i) '!!!注意
If mcolRateDirect(recTemp_1!lngCurrencyID) Then
If arrdblSumAmount(i) <> 0 Then
!dblRate = Abs(arrdblSumCurrency(i) / arrdblSumAmount(i))
End If
Else
If arrdblSumCurrency(i) <> 0 Then
!dblRate = Abs(arrdblSumAmount(i) / arrdblSumCurrency(i))
End If
End If
!dblQuantity = arrdblSumQuantity(i) '!!!注意
If arrdblSumQuantity(i) <> 0 Then
!dblPrice = Abs(arrdblSumCurrency(i) / arrdblSumQuantity(i))
Else
!dblPrice = 0
End If
!lngClassID1 = mlngClassID1(i + 1)
!lngClassID2 = mlngClassID2(i + 1)
'''!lngJobID = recTemp_1!lngJobID
!lngCustomerID = mlngCustomerID(i + 1)
!lngDepartmentID = mlngDepartmentID(i + 1)
!lngEmployeeID = mlngEmployeeID(i + 1)
lngVoucherDetailID = BillPublic.GetNewID("VoucherDetail")
!lngVoucherDetailID = lngVoucherDetailID
.Update
End With
End If
Next i
'修改科目发生额及余额
If ChangeAllAccount_from_Voucher("I", lngVoucherID) = False Then
GoTo DoTransErr
End If
Set recTemp_1 = Nothing
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -