📄 frmcalccost.frm
字号:
ShowMsg hwnd, "程序出错：" & Err.Description, vbOKOnly + vbCritical, Caption
End Select
Set clsVoucher = Nothing
End Function
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' 查找过程
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub cmdAgain_Click()
Dim lngRow As Long
Dim intResult As Integer
On Error Resume Next
With mclsGrid.Grid
If .Row >= .FixedRows Then
If .Row < .Rows - 1 Then
lngRow = .Row + 1
Else
lngRow = .FixedRows
End If
intResult = StrComp(Left$(.CellValue(lngRow, mclsGrid.SortCol), Len(txtFind.Text)), txtFind.Text, vbTextCompare)
If mclsGrid.SortType = 1 Then
'升序
Select Case intResult
Case -1 '小于
Do While lngRow < .Rows - 1 And intResult = -1
lngRow = lngRow + 1
intResult = StrComp(Left$(.CellValue(lngRow, mclsGrid.SortCol), Len(txtFind.Text)), txtFind.Text, vbTextCompare)
Loop
Case 0 '等于
Case 1 '大于
Do While lngRow > .FixedRows And intResult = 1
lngRow = lngRow - 1
intResult = StrComp(Left$(.CellValue(lngRow, mclsGrid.SortCol), Len(txtFind.Text)), txtFind.Text, vbTextCompare)
Loop
End Select
Else
'降序
Select Case intResult
Case -1 '小于
Do While lngRow > .FixedRows And intResult = 1
lngRow = lngRow - 1
intResult = StrComp(Left$(.CellValue(lngRow, mclsGrid.SortCol), Len(txtFind.Text)), txtFind.Text, vbTextCompare)
Loop
Case 0 '等于
Case 1 '大于
Do While lngRow < .Rows - 1 And intResult = -1
lngRow = lngRow + 1
intResult = StrComp(Left$(.CellValue(lngRow, mclsGrid.SortCol), Len(txtFind.Text)), txtFind.Text, vbTextCompare)
Loop
End Select
End If
If intResult = 0 Then
'找到
.Row = lngRow
End If
End If
End With
End Sub
Private Sub InitSort(Optional ByVal strTitle As String)
Dim lngCnt As Long
Dim intIndex As Integer
strTitle = Replace(strTitle, "↑", "")
strTitle = Replace(strTitle, "↓", "")
intIndex = -1
cboCost(3).Clear
For lngCnt = 1 To mclsGrid.ListSet.Columns - 1
If mclsGrid.ListSet.ColumnOrderType(lngCnt) > 0 Then
cboCost(3).AddItem mclsGrid.ListSet.ColumnDesc(lngCnt)
If strTitle = mclsGrid.ListSet.ColumnDesc(lngCnt) Then
intIndex = lngCnt - 1
End If
End If
Next lngCnt
If intIndex >= 0 Then
cboCost(3).ListIndex = intIndex
End If
End Sub
Private Sub SortClick()
Dim lngCnt As Long
If mblnSort Then
For lngCnt = 1 To mclsGrid.Grid.Cols - 1
If lngCnt <> mclsGrid.SortCol And mclsGrid.Grid.CellValue(0, lngCnt) = cboCost(3).Text Then
mclsGrid.Sort lngCnt
Exit For
End If
Next lngCnt
End If
End Sub
'是否存在只有金额的入库单
Private Function ChoiceAmt(strPeriod As String) As Boolean
Dim strSql As String
Dim recDetail As rdoResultset
Dim lngChoicePeriod As Long
Dim intYear As Integer
Dim bytPeriod As Integer
Dim strIDs As String
ChoiceAmt = True
intYear = GetintYear(strPeriod)
bytPeriod = GetbytPeriod(strPeriod)
lngChoicePeriod = CLng(intYear) * 100 + bytPeriod
strSql = "DELETE FROM ItemActivityDetail " _
& "WHERE lngActivityID IN (SELECT lngActivityID FROM ItemActivity " _
& "WHERE intYear=" & intYear & " AND bytPeriod=" & bytPeriod & " " _
& "AND lngActivityTypeID=" & atOutCostAdjust & " AND strReceiptNo='CB')"
gclsBase.ExecSQL strSql
strSql = "DELETE FROM ItemActivity " _
& "WHERE intYear=" & intYear & " AND bytPeriod=" & bytPeriod & " AND strReceiptNo='CB' " _
& "AND lngActivityTypeID=" & atOutCostAdjust
gclsBase.ExecSQL strSql
strSql = "SELECT lngActivityDetailID FROM ItemActivityDetail,ItemActivity,Item,ItemNature,ReceiptType " _
& "WHERE Item.lngItemNatureID=ItemNature.lngItemNatureID " _
& "AND ItemActivityDetail.lngItemID=Item.lngItemID " _
& "AND ItemActivity.lngReceiptTypeID=ReceiptType.lngReceiptTypeID " _
& "AND ItemActivityDetail.lngActivityID=ItemActivity.lngActivityID " _
& "AND dblQuantity=0 AND dblAmount<>0 AND lngActivityTypeID IN (1,2,3,5,8,9,10) " _
& "AND strItemCategory='1' AND (strCostMethod='3' OR strCostMethod='4') " _
& "AND (lngCostOrder=" & 0 _
& " OR lngCostOrder>=" & lngChoicePeriod & ") AND blnIsVoid=0"
Set recDetail = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
If Not recDetail.EOF Then
Do While Not recDetail.EOF
If strIDs = "" Then
strIDs = recDetail!lngActivityDetailID
Else
strIDs = strIDs & "," & recDetail!lngActivityDetailID
End If
recDetail.MoveNext
Loop
recDetail.Close
ChoiceAmt = FrmCalcAmount.SetParameters(strPeriod)
If Not ChoiceAmt Then
strSql = "UPDATE ItemActivityDetail SET lngCostOrder=0 " _
& "WHERE lngActivityDetailID IN (" & strIDs & ")"
gclsBase.ExecSQL strSql
End If
Else
recDetail.Close
End If
BillPublic.blnMaxNODecrease intYear, bytPeriod, rtOutCostAdjust, "CB", 99999999
End Function
'是否存在已制作凭证的出库单
Private Function ClearActivityVoucher(dtmStart As Date, dtmEnd As Date) As Boolean
Dim strSql As String
Dim recDetail As rdoResultset
Dim clsVoucher As clsVoucherMethod
Dim blnExistVoucher As Boolean
Dim blnOK As Boolean
Dim arrDetail() As Long
Dim lngArrCnt As Long
ClearActivityVoucher = True
Set clsVoucher = New clsVoucherMethod
lngArrCnt = -1
strSql = "SELECT ItemActivity.lngActivityID, ItemActivity.lngActivityTypeID,ItemActivity.lngVoucherID1," _
& "Voucher.lngPostID,Voucher.lngCheckerID " _
& "FROM ItemActivity,Voucher " _
& "WHERE ItemActivity.lngVoucherID1=Voucher.lngVoucherID " _
& "AND (ItemActivity.lngActivityTypeID In (5,11,13,16,15,19,20,21,22,31,33)) " _
& "AND ItemActivity.lngVoucherID1>0 AND ItemActivity.strDate>='" & Format(dtmStart, "yyyy-mm-dd") _
& "' AND ItemActivity.strDate<='" & Format(dtmEnd, "yyyy-mm-dd") & "'"
Set recDetail = gclsBase.BaseDB.OpenResultset(strSql, rdOpenForwardOnly)
Do While Not recDetail.EOF
lngArrCnt = lngArrCnt + 1
ReDim Preserve arrDetail(4, lngArrCnt)
arrDetail(0, lngArrCnt) = recDetail!lngActivityID
arrDetail(1, lngArrCnt) = recDetail!lngActivityTypeID
arrDetail(2, lngArrCnt) = recDetail!lngVoucherID1
arrDetail(3, lngArrCnt) = recDetail!lngPostID
arrDetail(4, lngArrCnt) = recDetail!lngCheckerID
recDetail.MoveNext
Loop
recDetail.Close
Set recDetail = Nothing
If lngArrCnt >= 0 And ClearActivityVoucher Then
blnExistVoucher = True
If ShowMsg(hwnd, "本期有部分单据已制作凭证！" + Chr(10) + "重新计算成本之前系统将自动删除这些凭证", vbOKCancel + vbQuestion + vbDefaultButton2, Caption) = vbOK Then
gclsBase.BaseWorkSpace.BeginTrans
Do While lngArrCnt >= 0 And ClearActivityVoucher
If arrDetail(3, lngArrCnt) > 0 Or arrDetail(4, lngArrCnt) > 0 Then
'生成冲销凭证
ClearActivityVoucher = False
ShowMsg hwnd, "单据" & IDToReceiptNo(arrDetail(0, lngArrCnt)) & "生成的凭证已记帐或复核，请取消记帐或复核，再计算成本", vbOKOnly + vbExclamation, Caption
Else
'删除过时凭证
strSql = "UPDATE ItemActivity SET lngVoucherID=DECODE(lngVoucherID," & arrDetail(2, lngArrCnt) & ",0,lngVoucherID)," _
& "lngVoucherID1=DECODE(lngVoucherID1," & arrDetail(2, lngArrCnt) & ",0,lngVoucherID1) " _
& "WHERE lngVoucherID=" & arrDetail(2, lngArrCnt) & " OR lngVoucherID1=" & arrDetail(2, lngArrCnt)
gclsBase.ExecSQL strSql
gclsSys.SendMessage Me.hwnd, msgReceipt41
ClearActivityVoucher = clsVoucher.DeleteVoucher(arrDetail(2, lngArrCnt), True)
If Not ClearActivityVoucher Then
ShowMsg hwnd, "凭证" & IDToVoucherNo(arrDetail(2, lngArrCnt)) & "删除失败!", vbOKOnly + vbExclamation, Caption
End If
End If
lngArrCnt = lngArrCnt - 1
Loop
If ClearActivityVoucher Then
gclsBase.BaseWorkSpace.CommitTrans
Else
gclsBase.BaseWorkSpace.RollBacktrans
End If
Else
ClearActivityVoucher = False
End If
End If
If ClearActivityVoucher Then
lngArrCnt = -1
strSql = "SELECT SettleActivity.lngActivityID,SettleActivity.lngActivityTypeID," _
& "SettleActivity.lngVoucherID,Voucher.lngPostID,Voucher.lngCheckerID " _
& "FROM ItemActivityDetail SettleDetail,ItemActivity SettleActivity,Voucher," _
& "ItemActivityDetail OutDetail,ItemActivity OutActivity " _
& "WHERE SettleActivity.lngVoucherID=Voucher.lngVoucherID " _
& "AND SettleDetail.lngActivityID=SettleActivity.lngActivityID " _
& "AND OutDetail.lngActivityID=OutActivity.lngActivityID " _
& "AND SettleDetail.lngOrderDetailID=OutDetail.lngActivityDetailID " _
& "AND (OutActivity.lngActivityTypeID In (5,14,16,15,19,21,22,31,33)) " _
& "AND SettleActivity.lngVoucherID>0 AND OutActivity.strDate>='" _
& Format(dtmStart, "yyyy-mm-dd") & "' AND OutActivity.strDate<='" _
& Format(dtmEnd, "yyyy-mm-dd") & "'"
Set recDetail = gclsBase.BaseDB.OpenResultset(strSql, rdOpenForwardOnly)
Do While Not recDetail.EOF
lngArrCnt = lngArrCnt + 1
ReDim Preserve arrDetail(4, lngArrCnt)
arrDetail(0, lngArrCnt) = recDetail!lngActivityID
arrDetail(1, lngArrCnt) = recDetail!lngActivityTypeID
arrDetail(2, lngArrCnt) = recDetail!lngVoucherID
arrDetail(3, lngArrCnt) = recDetail!lngPostID
arrDetail(4, lngArrCnt) = recDetail!lngCheckerID
recDetail.MoveNext
Loop
recDetail.Close
Set recDetail = Nothing
If lngArrCnt >= 0 And ClearActivityVoucher Then
If Not blnExistVoucher Then
blnOK = (ShowMsg(hwnd, "本期有部分单据已制作凭证！" + Chr(10) + "重新计算成本之前系统将自动删除这些凭证", vbOKCancel + vbQuestion + vbDefaultButton2, Caption) = vbOK)
Else
blnOK = True
End If
blnExistVoucher = True
If blnOK Then
gclsBase.BaseWorkSpace.BeginTrans
Do While lngArrCnt >= 0 And ClearActivityVoucher
If arrDetail(3, lngArrCnt) > 0 Or arrDetail(4, lngArrCnt) > 0 Then
'生成冲销凭证
ClearActivityVoucher = False
ShowMsg hwnd, "单据" & IDToReceiptNo(arrDetail(0, lngArrCnt)) & "生成的凭证已记帐或复核，请取消记帐或复核，再计算成本", vbOKOnly + vbExclamation, Caption
Else
'删除过时凭证
strSql = "UPDATE ItemActivity SET lngVoucherID=0 WHERE lngVoucherID=" & arrDetail(2, lngArrCnt)
gclsBase.ExecSQL strSql
gclsSys.SendMessage Me.hwnd, msgReceipt41
ClearActivityVoucher = clsVoucher.DeleteVoucher(arrDetail(2, lngArrCnt), True)
If Not ClearActivityVoucher Then
ShowMsg hwnd, "凭证" & IDToVoucherNo(arrDetail(2, lngArrCnt)) & "删除失败!", vbOKOnly + vbExclamation, Caption
End If
End If
lngArrCnt = lngArrCnt - 1
Loop
If ClearActivityVoucher Then
gclsBase.BaseWorkSpace.CommitTrans
Else
gclsBase.BaseWorkSpace.RollBacktrans
End If
Else
ClearActivityVoucher = False
End If
End If
End If
Set clsVoucher = Nothing
End Function
Private Function AddstrPeriod(ByVal strPeriod As String) As String
Dim intCnt As Integer
For intCnt = 0 To cboCost(0).ListCount - 1
If strPeriod = cboCost(0).list(intCnt) Then
intCnt = intCnt + 1
Exit For
End If
Next intCnt
If intCnt <= cboCost(0).ListCount - 1 Then
AddstrPeriod = cboCost(0).list(intCnt)
Else
AddstrPeriod = ""
If cboCost(0).ListCount > 1 Then
If strPeriod < cboCost(0).list(1) Then
AddstrPeriod = cboCost(0).list(1)
End If
End If
End If
End Function
Private Function EntrustInFromOut(dtmEnd As Date) As Boolean
Dim strSql As String
Dim recEntrust As rdoResultset
strSql = "SELECT lngActivityDetailID FROM ItemActivityDetail,ItemActivity,EntrustInToOut " _
& "WHERE ItemActivityDetail.lngActivityID=ItemActivity.lngActivityID " _
& "AND ItemActivityDetail.lngActivityDetailID=EntrustInToOut.lngInActivityDetailID(+) " _
& "AND lngActivityTypeID=" & atInEntrust & " AND strDate<='" & Format(dtmEnd, "yyyy-mm-dd") & "' " _
& "AND NVL(EntrustInToOut.lngOutActivityDetailID,0)=0 AND (blnIsVoid=0) AND ItemActivityDetail.dblQuantity>0"
Set recEntrust = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
EntrustInFromOut = recEntrust.EOF
recEntrust.Close
Set recEntrust = Nothing
If Not EntrustInFromOut Then
ShowMsg hwnd, "加工入库单中的商品未指定对应加工出库商品，不能计算成本！", vbOKOnly + vbExclamation, Caption
End If
End Function
Private Function CloseCost(strPeriod As String) As Boolean
Dim strSql As String
Dim recVoucher As rdoResultset
Dim intYear As Integer
Dim intPeriod As Integer
intYear = GetintYear(strPeriod)
intPeriod = GetbytPeriod(strPeriod)
strSql = "SELECT strDate,bytPeriod,lngVoucherID,lngPostID FROM Voucher WHERE intYear=" _
& intYear & " AND bytPeriod=" & intPeriod & " AND lngVoucherSourceID=" & vsCost _
& " AND blnIsVoid=0"
Set recVoucher = gclsBase.BaseDB.OpenResultset⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -