frmcostprice.frm

金算盘软件代码

                    NewReceiptDate = gclsBase.BaseDate
                    blnModifyMaxNO gclsBase.FYearOfDate(NewReceiptDate), gclsBase.PeriodOfDate(NewReceiptDate), C2lng(lblHead(2).Tag), _
                       SubStr(strAlphaOfStr(LTrim(strNewReceiptNO)), 1, 6), _
                       strDigitOfStr(LTrim(strNewReceiptNO))

                    'clsBill.lngNowID = 0
                    clsBill.blnIsChanged = False
                    cmdNext_Click
                    'ShowANewBill , False
                End If
            End If
        Case 2  'BAR
        Case 3  '复制单据
            clsBill.SaveBillToCollection
        Case 4  '粘贴单据
            clsBill.LoadBillFromCollection
        Case 5  'BAR
        Case 6  '搜索
            frmTreeFind.ShowFind
        Case 7  '查询单据缺号
            Dim frmTmp As Form
            Set frmTmp = New frmBillNo
            frmTmp.ShowTypeID C2lng(lblHead(2).Tag)
            Set frmTmp = Nothing
        Case 9  '模板表体列宽恢复
            ModifyColWidthDefault Me
            clsBill.TemplateChange C2lng(lblHead(4).Tag)
        Case 11
            CallBillList 32, True
        Case 12
            CallBillList 32, False
        Case 13
            GotoOldBill
        Case 14
            mclsMainControl_FilePrintReceipt
    End Select
EndProc:
    '合计行计算
    clsBill.WriteTotal
End Sub
Private Sub refTmpID_Change()
    clsBill.TemplateChange C2lng(lblHead(4).Tag)
End Sub

Private Sub SaveActivity(recTmp As rdoResultset)
    Dim strTmp As String
    With recTmp
        !blnIsPrinted = 0
        !intYear = gclsBase.FYearOfDate(C2Date(lblField(2).Caption))
        !bytPeriod = gclsBase.PeriodOfDate(C2Date(lblField(2).Caption))
        strTmp = SubStr(strAlphaOfStr(LTrim(lblField(1).Caption)), 1, 6)      '文本,入库成本单编号
        strTmp = IIf(strTmp = "", " ", strTmp)
        !strReceiptNo = strTmp
        !lngReceiptNo = C2lng(BillPublic.strDigitOfStr(LTrim(lblField(1).Caption)))         '数字,入库成本单编号
        !lngTemplateID = C2lng(lblHead(5 - 1).Tag)                     '数字,模版ID
        BillPublic.setPrevPlateAndBillNo 32, !lngTemplateID, !strReceiptNo
        !lngClassID2 = clsBill.getFieldID(5)                           '统计（项目）ID
        !lngClassID1 = clsBill.getFieldID(6)                           '统计ID
        !lngDepartmentID = clsBill.getFieldID(4)                       '数字,部门ID
        !lngEmployeeID = clsBill.getFieldID(3)                         '数字,员工ID
        strTmp = lblField(2).Caption                               '文本,制单日
        strTmp = IIf(strTmp = "", " ", strTmp)
        !strDate = strTmp
        !lngOperatorID = IIf(C2lng(lblmemo(lblmemo.Count - 1).Tag) > 0, C2lng(lblmemo(lblmemo.Count - 1).Tag), gclsBase.OperatorID)                         '数字,操作员ID
        Dim strT As String
        strT = Trim(lblmemo(1).Caption)
        strTmp = IIf(StrLen(strT) < 40, strT, SubStr(strT, 1, 40))  '文本,备注
        strTmp = IIf(strTmp = "", " ", strTmp)
        !strNote = strTmp
        !blnIsPrint = chkPrint(0).Value          '是/否,打印标志
        !blnIsVoid = chkPrint(1).Value           '是/否,作废标志
        !blnIsPost = 1
    End With
End Sub
Private Sub SaveActivityDetailBody(recTmp As rdoResultset, ByVal i As Integer)
    Dim strTmp As String
    With recTmp
    
    !lngItemID = C2lng(clsBill.strGrdCell(i, 12))      '商品ID
    !lngUnitID = C2lng(clsBill.strGrdCell(i, 13))      '计量单位ID
    !dblQuantity = C2Dbl(NumberConvert(clsBill.strGrdCell(i, 3), ConvertFactor(!lngUnitID, !lngItemID), True))                           '数量
'    !dblPrice = C2Dbl(clsBill.strGrdCell(i, 4)) / ConvertFactor(!lngUnitID, !lngItemID)  '成本单价
    !dblAmount = C2Dbl(clsBill.strGrdCell(i, 5))                               '成本金额
    If !dblQuantity <> 0 Then
        !dblPrice = !dblAmount / !dblQuantity
    Else
        !dblPrice = C2Dbl(clsBill.strGrdCell(i, 4)) / ConvertFactor(!lngUnitID, !lngItemID)  '成本单价
    End If
    gclsBase.BaseDB.Execute "UPDATE Item SET dblCostPrice=" & !dblPrice & " WHERE lngItemID=" & !lngItemID
    !lngCustomID0 = C2lng(clsBill.strGrdCell(i, 14))                           '自定项目ID0
    !lngCustomID1 = C2lng(clsBill.strGrdCell(i, 15))   '自定项目ID1
    !lngCustomID2 = C2lng(clsBill.strGrdCell(i, 16))   '自定项目ID2
    !lngCustomID3 = C2lng(clsBill.strGrdCell(i, 17))   '自定项目ID3
    !lngCustomID4 = C2lng(clsBill.strGrdCell(i, 18))  '自定项目ID4
    !lngCustomID5 = C2lng(clsBill.strGrdCell(i, 19))  '自定项目ID5
'    !strRemark = clsbill.strgrdcell(i, 1) + " "                                '备注
    '设已存储标志
    grdCol.TextMatrix(i, 0) = !lngCostPriceDetailID
    End With
End Sub
Private Function SaveGoShare(ByVal lngRowno As Long, Optional blnDoTrans As Boolean = False) As Boolean
    Dim strSql As String
    Dim rectemp1 As rdoResultset
    Dim i As Integer
    Dim dblPrice As Double
    Dim dblOldPrice As Double
    Dim dblFactor As Double
    Dim dblQuantity As Double
    Dim dblTaxRate As Double
        
    dblFactor = ConvertFactor(C2lng(grdCol.TextMatrix(lngRowno, 13)), C2lng(grdCol.TextMatrix(lngRowno, 12)))
    dblPrice = C2Dbl(grdCol.TextMatrix(lngRowno, 4)) / dblFactor
    If chkPrint(1).Value = 1 Then Exit Function
    On Error GoTo ErrHandle
    If Trim(grdCol.TextMatrix(lngRowno, 21)) = "" Then
        clsBill.ShowMsgOther Me.hwnd, "第" & lngRowno & "行没有选择自制入库单据，不能保存！", MB_SYSTEMMODAL + MB_OK + MB_ICONEXCLAMATION, "保存单据"
        clsBill.blnIsChanged = True
        grdCol.TextMatrix(lngRowno, 3) = ""
        grdCol.TextMatrix(lngRowno, 4) = ""
        grdCol.TextMatrix(lngRowno, 5) = ""
        clsBill.WriteTotal
        grdCol.Row = lngRowno
        grdCol.col = 1
        clsBill.grdCol_EnterCell
        Exit Function
    End If
    If blnDoTrans Then
      gclsBase.BaseWorkSpace.BeginTrans
    End If
    strSql = "SELECT SUM(dblQuantity) FROM ItemActivityDetail WHERE lngItemID=" & grdCol.TextMatrix(lngRowno, 12) & " and lngActivityDetailID IN (" & grdCol.TextMatrix(lngRowno, 21) & ")"
    Set rectemp1 = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If Not (rectemp1.BOF And rectemp1.EOF) Then
        If IIf(IsNull(rectemp1(0)), 0, rectemp1(0)) = C2Dbl(NumberConvert(clsBill.strGrdCell(lngRowno, 3), dblFactor)) Then
            rectemp1.Close
            Set rectemp1 = Nothing
            GoTo OK
        End If
    End If
    rectemp1.Close
    Set rectemp1 = Nothing
    clsBill.ShowMsgOther Me.hwnd, "第" & lngRowno & "行的商品（" & grdCol.TextMatrix(lngRowno, 1) & "）数量错误，请重新选择单据！", MB_OK + MB_SYSTEMMODAL + MB_ICONEXCLAMATION, "保存单据"
    SaveGoShare = False
    Exit Function
OK:
    Dim strTmp As String
    Dim lngTmp As Long
    strTmp = grdCol.TextMatrix(lngRowno, 21)
    If Trim(strTmp) <> "" Then
        If InStr(strTmp, ",") <> 0 Then
            lngTmp = C2lng(ShareString(strTmp, ","))
        Else
            lngTmp = C2lng(strTmp)
            strTmp = ""
        End If
        Do While lngTmp <> 0
            If clsBill.blnStockBillCanChange(lngTmp) = False Then
               GoTo ErrHandle
            End If
            strSql = "SELECT * FROM ItemActivityDetail WHERE lngActivityDetailID=" & lngTmp & " AND lngItemID=" & grdCol.TextMatrix(lngRowno, 12)
            Set rectemp1 = gclsBase.BaseDB.OpenResultset(strSql, rdOpenDynamic, rdConcurValues)
            With rectemp1
                If Not (.BOF And .EOF) Then
                    While Not .EOF
                        .Edit
                        dblOldPrice = !dblCurrPrice
                        dblQuantity = !dblQuantity
                        !dblCurrPrice = dblPrice
                        If dblOldPrice <> 0 Then
                            !dblCurrAmount = Format(!dblCurrAmount * dblPrice / dblOldPrice, FormatString(gclsBase.NaturalCurDec))
                            !dblAmount = Format(!dblAmount * dblPrice / dblOldPrice, FormatString(gclsBase.NaturalCurDec))
                            !dblCurrTaxAmount = Format(!dblCurrTaxAmount * dblPrice / dblOldPrice, FormatString(gclsBase.NaturalCurDec))
                            !dblTaxAmount = Format(!dblTaxAmount * dblPrice / dblOldPrice, FormatString(gclsBase.NaturalCurDec))
                        Else
                            !dblCurrAmount = Format(dblPrice * dblQuantity, FormatString(gclsBase.NaturalCurDec))
                            !dblAmount = Format(dblPrice * dblQuantity, FormatString(gclsBase.NaturalCurDec))
                            !dblCurrTaxAmount = 0       ' Format(dblPrice * dblQuantity, FormatString(gclsBase.NaturalCurDec))
                            !dblTaxAmount = 0           'Format(dblPrice * dblQuantity, FormatString(gclsBase.NaturalCurDec))
                        End If
                        
                        If clsBill.strCostMethod(lngRowno) = "6" Then       ' 6 计划价(进价核算)
                            !dblPlanPrice = clsBill.GetPlanPrice(lngRowno)   '本币计划价
                            !dblCostAmount = Format(!dblPlanPrice * !dblQuantity, FormatString(gclsBase.NaturalCurDec))
                            !dblCostDiff = !dblAmount - !dblCostAmount
                            !dblSaleTax = 0
                        ElseIf clsBill.strCostMethod(lngRowno) = "7" Then       ' 7   实际差价率
                            dblTaxRate = clsBill.GetTaxRate(lngRowno, False)
                            !dblPlanPrice = clsBill.GetRetainPrice(lngRowno)
                            !dblCostAmount = Format(clsBill.GetRetainPrice(lngRowno) * !dblQuantity, FormatString(gclsBase.NaturalCurDec))
                            !dblSaleTax = Format(!dblCostAmount * dblTaxRate / (1 + dblTaxRate), FormatString(gclsBase.NaturalCurDec))
                            !dblCostDiff = !dblAmount - !dblCostAmount + !dblSaleTax
                        Else
                            !dblCostAmount = !dblAmount
                            !dblCostDiff = 0
                            !dblSaleTax = 0
                        End If

                        !dblAvgCostAmount = !dblCostAmount
                        
                        
    '                    !dblCostAmount = Format(!dblQuantity * dblPrice, FormatString(gclsBase.NaturalCurDec))
    '                    !dblCostDiff = Format((!dblPlanPrice - dblPrice) * !dblQuantity, FormatString(gclsBase.NaturalCurDec))
                        !lngOrderDetailID = clsBill.lngNowID
                        .Update
                        .MoveNext
                    Wend
                End If
    '            strSql = "INSERT INTO CostPriceToPurchase (lngCostPriceID,lngPurchaseActivityDetailID) VALUES (" & clsBill.lngNowID & "," & lngReceipts(i) & ")"
    '            gclsBase.BaseDB.Execute strSql
            End With
            rectemp1.Close
            Set rectemp1 = Nothing
            If strTmp <> "" Then
                If InStr(strTmp, ",") = 0 Then
                    lngTmp = C2lng(strTmp)
                    strTmp = ""
                Else
                    lngTmp = C2lng(ShareString(strTmp, ","))
                End If
            Else
                lngTmp = 0
            End If
        Loop
    End If
'    Next
    If blnDoTrans Then
      gclsBase.BaseWorkSpace.CommitTrans
    End If
    SaveGoShare = True
    Exit Function
ErrHandle:
    If blnDoTrans Then
      gclsBase.BaseWorkSpace.RollBacktrans
    End If
End Function
Private Function ClearSaveGoShare(ByVal lngRowno As Long, Optional ByVal lngItemID As Long = 0, Optional blnDoTrans As Boolean = False) As Boolean
    Dim recTmp As rdoResultset
    If lngItemID = 0 Then
        strSql = "SELECT ItemActivityDetail.lngActivityDetailID FROM ItemActivity,ItemActivityDetail WHERE ItemActivity.lngActivityID=ItemActivityDetail.lngActivityID " _
        & " AND ItemActivity.lngReceiptTypeID=9 AND ItemActivityDetail.lngOrderDetailID=" & clsBill.lngNowID _
        & " AND ItemActivityDetail.lngItemID=" & C2lng(grdCol.TextMatrix(lngRowno, 12))
    Else
        strSql = "SELECT ItemActivityDetail.lngActivityDetailID FROM ItemActivity,ItemActivityDetail WHERE ItemActivity.lngActivityID=ItemActivityDetail.lngActivityID " _
        & " AND ItemActivity.lngReceiptTypeID=9 AND ItemActivityDetail.lngOrderDetailID=" & clsBill.lngNowID _
        & " AND ItemActivityDetail.lngItemID=" & lngItemID
    End If
    On Error GoTo ErrHandle
    If blnDoTrans Then
      gclsBase.BaseWorkSpace.BeginTrans
    End If
    Set recTmp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If Not (recTmp.BOF And recTmp.EOF) Then
        While Not recTmp.EOF
            strSql = "Update ItemActivityDetail Set lngOrderDetailID=0 WHERE lngActivityDetailID=" & recTmp(0)
            If gclsBase.ExecSQL(strSql) = False Then
               GoTo ErrHandle
            End If
            recTmp.MoveNext
        Wend
    End If
    recTmp.Close
    Set recTmp = Nothing
    If blnDoTrans Then
      gclsBase.BaseWorkSpace.CommitTrans
    End If
    ClearSaveGoShare = True
    Exit Function
ErrHandle:
    recTmp.Close
    Set recTmp = Nothing
    If blnDoTrans Then
      gclsBase.BaseWorkSpace.RollBacktrans
    End If
End Function
Private Function BeforeSaveGoShare(Optional blnDoTrans As Boolean = False) As Boolean
'    If clsBill.lngNowID = 0 Then Exit Sub
    Dim strReceipts As String
    Dim recTmp As rdoResultset
    Dim i As Integer
    Dim lngOldActivityID As Long
    
    strReceipts = ""
    For i = 1 To grdCol.Rows - 1
        If Trim(grdCol.TextMatrix(i, 21)) <> "" Then
            If strReceipts = "" Then
                strReceipts = grdCol.TextMatrix(i, 21)
            Else
                strReceipts = strReceipts & "," & grdCol.TextMatrix(i, 21)
            End If
        End If
    Next
    If Trim(strReceipts) = "" Then
        BeforeSaveGoShare = True
        Exit Function
    End If
    On Error GoTo ErrHandle
    If blnDoTrans Then
      gclsBase.BaseWorkSpace.BeginTrans
    End If
    strSql = "SELECT MIN(ItemActivity.lngActivityID) FROM ItemActivity , ItemActivityDetail WHERE ItemActivity.lngActivityID=ItemActivityDetail.lngActivityID" _
    & " AND ItemActivityDetail.lngActivityDetailID IN (" & strReceipts & ") GROUP BY ItemActivity.lngActivityID"
    
    Set recTmp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If Not (recTmp.BOF And recTmp.EOF) Then
        While Not recTmp.EOF
            If recTmp(0) = lngOldActivityID Then GoTo Pass1
            lngOldActivityID = recTmp(0)
            '修改商品表及采购销售订单明细表
            If Not ModifyItemTable(lngOldActivityID, False) Then
                GoTo ErrHandle
            End If
            '修改各种余额表
            If Not ChangeAllItem_from_Activity("D", lngOldActivityID) Then
                GoTo ErrHandle
            End If
Pass1:
            recTmp.MoveNext
        Wend
        BeforeSaveGoShare = True
    End If
EndProc:
    If Not recTmp Is Nothing Then
        recTmp.Close
        Set recTmp = Nothing
    End If
    If blnDoTrans Then
      gclsBase.BaseWorkSpace.CommitTrans
    End If
    Exit Function
ErrHandle:
    If Not recTmp Is Nothing Then
        recTmp.Close
        Set recTmp = Nothing
    End If
    If blnDoTrans Then
      gclsBase.BaseWorkSpace.RollBacktrans
    End If
End Function
Private Function FinishSaveGoShare(Optional blnDoTrans As Boolean = False) As Boolean
'If clsBill.lngNowID = 0 Then Exit Sub
    Dim strReceipts As String
    Dim recTmp As rdoResultset
    Dim i As Integer
    Dim lngOldActivityID As Long
    
    strReceipts = ""
    For i = 1 To grdCol.Rows - 1
        If Trim(grdCol.TextMatrix(i, 21)) <> "" Then
            If strReceipts = "" Then
                strReceipts = grdCol.