frmadjustprice.frm

金算盘软件代码

             !lngClassID1 = clsBill.getFieldID(6)  '统计ID
             !lngClassID2 = clsBill.getFieldID(5) '项目ID
             !strDate = lblField(2).Caption  '日期
             !lngOperatorID = C2lng(LblMemo(3).Tag)  '操作员ID
             If LblMemo(1) = "" Then
                !strNote = " "
             Else
                !strNote = SubStr(LblMemo(1), , 40) '备注
             End If
             !blnIsPrint = IIf(chkPrint(0).Value = 0, 0, 1) '打印标志
             '!blnIsVoid = IIf(chkPrint(1).Value = 0, 0, 1)
             
             !lngCurrencyID = gclsBase.NaturalCurId
             !dblRate = 1
        End With
End Sub

Private Sub SaveItemActivityDetailBody(recTmp As rdoResultset, ByVal i As Integer)
'3.调价单 (只有计划价和零售价的商品才可以调价)
'  成本金额         = 计划价：（新价 - 原价）* 调价数量
'                   = 零售价：（新价 - 原价）* 调价数量
'  待实现销项税     = 计划价：0
'                   = 零售价：（新价 - 原价）* 调价数量/（1+销项税率%）* 销项税
'  率%
'  成本差异 = 计划价: 成本金额
'               = 零售价：成本金额 + 待实现销项税
    With recTmp
         !dblDiscountRate = 100 '扣率
         !lngItemID = C2lng(GrdCol.TextMatrix(i, 20)) '商品ID
         !lngPositionID = C2lng(GrdCol.TextMatrix(i, 21)) '货位ID
         !lngUnitID = C2lng(GrdCol.TextMatrix(i, 22)) '单位ID
         dblFacter = ConvertFactor(C2lng(GrdCol.TextMatrix(i, 22)), C2lng(GrdCol.TextMatrix(i, 20)))
         !lngTaxID = C2lng(GrdCol.TextMatrix(i, 23)) '税率ID
         !dblQuantity = NumberConvert(GrdCol.TextMatrix(i, 5), dblFacter, True)  '数量
         
         !dblCurrPrice = C2Dbl(clsBill.strGrdCell(i, 4)) / dblFacter '原价
         !dblCurrNewPrice = C2Dbl(clsBill.strGrdCell(i, 6)) / dblFacter ' 现价
         '将调价金额存入原币、本币金额字段
         !dblTaxAmount = C2Dbl(clsBill.strGrdCell(i, 9)) '调价税额
         !dblAmount = C2Dbl(clsBill.strGrdCell(i, 7))  '调价金额（零售价时含税）
         !dblCurrAmount = !dblAmount
         
         '成本计算方法为计划价，只保存计划价。
         '若是实际差价率则保存销售价和零售价，不存计划价
         Dim strCostType As String
         strCostType = clsBill.GetCostMethod(i)
         Select Case strCostType
            Case "6"  '计划价
                !dblPlanPrice = clsBill.GetPlanPrice(i)
                !dblCostAmount = !dblAmount '本币成本金额
                !dblSaleTax = 0 '本币待实现销项税
                !dblCostDiff = !dblCostAmount '本币成本差异
            Case "7" '实际差价率
                !dblPlanPrice = clsBill.GetPlanPrice(i)
                !dblCostAmount = !dblAmount '本币成本金额
                !dblSaleTax = -C2Dbl(clsBill.strGrdCell(i, 9)) '调价税额 ' !dblAmount*  '本币待实现销项税
                !dblCostDiff = !dblCostAmount - !dblSaleTax '本币成本差异
            Case Else
                !dblPlanPrice = 0
                !dblCostAmount = 0 '本币成本金额
                !dblSaleTax = 0 '本币待实现销项税
                !dblCostDiff = 0 '本币成本差异
         End Select
         

         !lngRowID = i
         !strProduceNum = Trim(GrdCol.TextMatrix(i, 10))
         !strProduceDate = Format(Trim(GrdCol.TextMatrix(i, 11)), "yyyy-mm-dd")
         !strValidDate = Format(Trim(GrdCol.TextMatrix(i, 12)), "yyyy-mm-dd")
         !intValidDay = C2lng(GrdCol.TextMatrix(i, 13))
         
         !lngCustomID0 = C2lng(GrdCol.TextMatrix(i, 25))
         !lngCustomID1 = C2lng(GrdCol.TextMatrix(i, 26))
         !lngCustomID2 = C2lng(GrdCol.TextMatrix(i, 27))
         !lngCustomID3 = C2lng(GrdCol.TextMatrix(i, 28))
         !lngCustomID4 = C2lng(GrdCol.TextMatrix(i, 29))
         !lngCustomID5 = C2lng(GrdCol.TextMatrix(i, 30))
    End With
End Sub
Private Function SaveItemActivityDetailBody1() As Boolean
'3.调价单 (只有计划价和零售价的商品才可以调价)
'  成本金额         = 计划价：（新价 - 原价）* 调价数量
'                   = 零售价：（新价 - 原价）* 调价数量
'  待实现销项税     = 计划价：0
'                   = 零售价：（新价 - 原价）* 调价数量/（1+销项税率%）* 销项税
'  率%
'  成本差异 = 计划价: 成本金额
'               = 零售价：成本金额 + 待实现销项税
    Dim recTmp As rdoResultset
    Dim i As Integer
    Dim strSql As String
    Dim RECT As rdoResultset
    Dim lngItemID As Long
    Dim dblCurrPrice As Double
    Dim dblCurrNewPrice As Double
    Dim dblQuantity As Double
    Dim lngRow As Long
    Dim strProduceDate As String
    Dim strValidDate As String
    Dim intValidDay As Integer
    On Error GoTo ErrH
    lngRow = 1
    
    
     Set recTmp = gclsBase.BaseDB.OpenResultset( _
            "SELECT * FROM ItemActivityDetail WHERE lngActivityID=" & clsBill.lngNowID, _
             rdOpenDynamic, rdConcurValues)
    If recTmp Is Nothing Then
        Exit Function
    End If
    If recTmp.EOF = False Then
        GoTo ErrH
    End If
    
        If GrdCol.Rows >= 2 Then
            For i = 1 To GrdCol.Rows - 1
                If clsBill.blnNotNullRow(i) Then
                        strSql = "SELECT SUM(dblEndStockQuantity)" & _
                                 " FROM PositionBalance" & _
                                 " Where lngItemID = " & C2lng(GrdCol.TextMatrix(i, 20))
                        Set RECT = gclsBase.BaseDB.OpenResultset(strSql, rdOpenForwardOnly)
                        If RECT.EOF Then
                            GoTo ErrH
                        ElseIf IsNull(RECT(0)) Then
                            GoTo ErrH
                        Else
                            dblQuantity = RECT(0)  '数量
                        End If
                        RECT.Close
                        Set RECT = Nothing
                        If dblQuantity = 0 Then GoTo ErrH
                        strSql = "SELECT lngItemID, lngPositionID, strProduceNum, lngCustomID0, lngCustomID1, lngCustomID2,lngCustomID3,lngCustomID4,lngCustomID5,dblEndStockQuantity" & _
                                 " FROM PositionBalance" & _
                                 " Where dblEndStockQuantity<>0 AND lngItemID = " & C2lng(GrdCol.TextMatrix(i, 20))
                        Set RECT = gclsBase.BaseDB.OpenResultset(strSql, rdOpenForwardOnly)
                        If RECT.EOF Then
                            GoTo ErrH
                        End If
                        lngItemID = C2lng(GrdCol.TextMatrix(i, 20))
                        dblFacter = ConvertFactor(C2lng(GrdCol.TextMatrix(i, 22)), C2lng(GrdCol.TextMatrix(i, 20)))
                        dblCurrPrice = C2Dbl(clsBill.strGrdCell(i, 4)) / dblFacter '原价
                        dblCurrNewPrice = C2Dbl(clsBill.strGrdCell(i, 6)) / dblFacter ' 现价
                        Do While RECT.EOF = False
                            With recTmp
                                 .AddNew
                                 !lngActivityID = clsBill.lngNowID
                                 !lngActivityDetailID = GetNewID("ItemActivityDetail")
                                 
                                 !dblDiscountRate = 100 '扣率
                                 !lngItemID = lngItemID '商品ID
                                 !lngPositionID = RECT("lngPositionID")  '货位ID
                                 !strProduceNum = RECT("strProduceNum")
'                                 If clsBill.GetValidDay(i) > 0 Then
'                                    SetProductDate lngItemID, RECT("lngPositionID"), RECT("strProduceNum"), strProduceDate, strValidDate, intValidDay
'                                    !strProduceDate = Format(Trim(strProduceDate), "yyyy-mm-dd")
'                                    !strValidDate = Format(Trim(strValidDate), "yyyy-mm-dd")
'                                    !intValidDay = intValidDay
'                                 End If
                                 
                                 !lngCustomID0 = RECT("lngCustomID0")
                                 !lngCustomID1 = RECT("lngCustomID1")
                                 !lngCustomID2 = RECT("lngCustomID2")
                                 !lngCustomID3 = RECT("lngCustomID3")
                                 !lngCustomID4 = RECT("lngCustomID4")
                                 !lngCustomID5 = RECT("lngCustomID5")
                                 !dblQuantity = RECT("dblEndStockQuantity")  '数量
                                 
                                 !lngUnitID = C2lng(GrdCol.TextMatrix(i, 22)) '单位ID
                                 !lngTaxID = C2lng(GrdCol.TextMatrix(i, 23)) '税率ID
                                 !dblCurrPrice = dblCurrPrice '原价
                                 !dblCurrNewPrice = dblCurrNewPrice ' 现价
                                 '将调价金额存入原币、本币金额字段
                                 
                                 !dblTaxAmount = C2Dbl(clsBill.strGrdCell(i, 9)) * !dblQuantity / dblQuantity  '调价税额
                                 !dblCurrTaxAmount = !dblTaxAmount
                                 !dblAmount = (dblCurrNewPrice - dblCurrPrice) * !dblQuantity  '调价金额（零售价时含税）
                                 !dblCurrAmount = !dblAmount
                                 
                                 '成本计算方法为计划价，只保存计划价。
                                 '若是实际差价率则保存销售价和零售价，不存计划价
                                 Dim strCostType As String
                                 strCostType = clsBill.GetCostMethod(i)
                                 Select Case strCostType
                                    Case "6"  '计划价
                                        !dblPlanPrice = clsBill.GetPlanPrice(i)
                                        !dblCostAmount = !dblAmount '本币成本金额
                                        !dblSaleTax = 0 '本币待实现销项税
                                        !dblCostDiff = !dblCostAmount '本币成本差异
                                    Case "7" '实际差价率
                                        !dblPlanPrice = clsBill.GetPlanPrice(i)
                                        !dblCostAmount = !dblAmount '本币成本金额
                                        !dblSaleTax = !dblTaxAmount '调价税额 ' !dblAmount*  '本币待实现销项税
                                        !dblCostDiff = !dblCostAmount + !dblSaleTax '本币成本差异
                                    Case Else
                                        !dblPlanPrice = 0
                                        !dblCostAmount = 0 '本币成本金额
                                        !dblSaleTax = 0 '本币待实现销项税
                                        !dblCostDiff = 0 '本币成本差异
                                 End Select
                                !dblAvgCostAmount = !dblCostAmount
                                 
                                 !lngRowID = lngRow
                                 lngRow = lngRow + 1
                                .Update
                            End With
                            RECT.MoveNext
                        Loop
                        If ChangeItemPrice(lngItemID, dblCurrPrice, dblCurrNewPrice, False) = False Then
                            Err.Raise 10
                        End If
                Else
                    GoTo NextOne:
                End If
                
NextOne:
            Next i
        End If
    SaveItemActivityDetailBody1 = True
    On Error Resume Next
    If Not recTmp Is Nothing Then
        recTmp.Close
        Set recTmp = Nothing
    End If
    If Not RECT Is Nothing Then
        RECT.Close
        Set RECT = Nothing
    End If
    Exit Function
ErrH:
    On Error Resume Next
    If Not recTmp Is Nothing Then
        recTmp.Close
        Set recTmp = Nothing
    End If
    If Not RECT Is Nothing Then
        RECT.Close
        Set RECT = Nothing
    End If
End Function

Private Function SaveNewBill() As Boolean
    Dim recAdjustPrice As rdoResultset
    Dim recDetail As rdoResultset
    Dim recItem As rdoResultset
    Dim lngNewAdjustID As Long
    Dim dtmDate1 As Date
    Dim strAlpha As String, strSql As String
    Dim lngDigit As Long
    Dim i As Long
    If Me.Visible Then
        If ShowMsg(Me.hwnd, "调价单保存后不允许修改，是否继续？", MB_YESNO + MB_DEFBUTTON1 + MB_ICONQUESTION + MB_SYSTEMMODAL, "保存单据") = IDNO Then
            Exit Function
        End If
    End If
    If clsBill.DataValid9() = False Then
        GoTo EndProc
    End If
    
    For i = 1 To GrdCol.Rows - 1
        If AfterHaveActivity(C2lng(GrdCol.TextMatrix(i, 20)), lblField(2).Caption, 0) Then
            ShowMessage Me, "商品“" & GrdCol.TextMatrix(i, 1) & "”在“" & lblField(2).Caption & "”日及以后已发生业务，不允许调价！", MB_OK + MB_SYSTEMMODAL + MB_ICONEXCLAMATION, "保存单据"
            GoTo EndProc
        End If
    Next i
    
    Screen.MousePointer = vbHourglass
    
StartSaveBill:
    On Error GoTo ErrorHandle
    dtmDate1 = C2Date(lblField(2).Caption)
    clsBill.intAccountYear = gclsBase.FYearOfDate(dtmDate1)    '会计年度
    clsBill.bytAccountPeriod = gclsBase.PeriodOfDate(dtmDate1)    '会计期间
    
    gclsBase.BaseWorkSpace.BeginTrans
    strSql = "SELECT * FROM ItemActivity WHERE ROWNUM=0"
    Set recAdjustPrice = gclsBase.BaseDB.OpenResultset(strSql, rdOpenDynamic, rdConcurValues)
    If recAdjustPrice Is Nothing Then
        gclsBase.BaseWorkSpace.RollBacktrans
        GoTo EndProc
    End If
    With recAdjustPrice
        .AddNew
            !lngActivityID = GetNewID("ItemActivity")
            lngNewAdjustID = !lngActivityID
            !lngActivityTypeID = 29  '调出部门
            !lngReceiptTypeID = 29
            !dblRate = 1
            SaveAdjust recAdjustPrice
            '取出重用信息
            strAlpha = !strReceiptNo
            lngDigit = !lngReceiptNo
        .Update
        '设置已存储(修改)标志
       clsBill.lngNowID = lngNewAdjustID
    End With
    If SaveItemActivityDetailBody1() = False Then
        clsBill.lngNowID = 0
        gclsBase.BaseWorkSpace.RollBacktrans
        GoTo EndProc
    End If
   
''    Set recDetail = gclsBase.BaseDB.OpenRecordset( _
''            "SELECT * FROM ItemActivityDetail where lngActivityID=" & lngNewAdjustID, _
''            dbOpenDynaset, dbConsistent, dbOptimistic)
''    If recDetail Is Nothing Then
''        gclsBase.BaseWorkSpace.RollBack
''        GoTo EndProc
''    End If
''    With recDetail
''        If .RecordCount <> 0 Then
''            gclsBase.BaseWorkSpace.RollBack
''            GoTo EndProc
''        End If
''        If grdCol.Rows >= 2 Then
''            For i = 1 To grdCol.Rows - 1
''                If clsBill.blnNotNullRow(i) Then
''                    .AddNew
''                        !lngActivityID = lngNewAdjustID
''                        grdCol.TextMatrix(i, 0) = !lngActivityDetailID
''                        SaveItemActivityDetailBody recDetail, i
''                        '改变商品表单价
''                        If ChangeItemPrice(!lngItemID, !dblCurrPrice, !dblCurrNewPrice, False) = False Then
''                            gclsBase.BaseWorkSpace.RollBack
''                            GoTo EndProc
''                        End If
''                    .Update
''                Else
''                    GoTo NextOne:
''                End If
''
''NextOne:
''            Next i
''        End If
''    End With
        '修改各种余额表
    If Not ChangeAllItem_from_Activity("I", lngNewAdjustID) Then
        gclsBase.BaseWorkSpace.RollBacktrans
        clsBill.lngNowID = 0
        For i = 1 To GrdCol.Rows - 1
            GrdCol.TextMatrix(i, 0) = 0
        Next i
        GoTo EndProc
    End If
    
    Dim blnCommitted As Boolean
    blnCommitted = True
    gclsBase.BaseWorkSpace.CommitTrans
    
    '修改最大编号表
    If blnModifyMaxNO(clsBill.intAccountYear, clsBill.bytAccountPeriod, C2lng(lblHead(2).Tag), strAlpha, lngDigit) = False Then
'        gclsBase.BaseWorkSpace.RollBack
'        GoTo EndProc
    End If
    
    clsBill.blnIsChanged = False
    SaveNewBill = True
    gclsSys.SendMessage Me.hwnd, 30 +