mainmodule.bas

针对农资系统的商品进销存管理系统软件

    Dim FindRs As ADODB.Recordset
    
    Set FindRs = AdoRs.Clone
    nRet = vbNo
    With FindRs
        Do While Not .EOF
            .Find "FNo Like '%" & sNo & "%'"
            If Not .EOF Then
                AdoRs.AbsolutePosition = .AbsolutePosition
                nRet = MsgBox("是本张单据吗？", vbYesNo + vbQuestion, "提示: ")
                If nRet = vbYes Then Exit Do
                .MoveNext
            End If
        Loop
    End With
    
    If nRet = vbNo Then
        MsgBox "查无此单据！", vbOKOnly + vbInformation, "提示:"
    End If
    Set FindRs = Nothing
End Sub

'/////////////////////////////////////////////////
'//入库单据记帐
Public Function WaresInRecord(nYear As Integer, byMonth As Byte, byType As Byte, sNo As String, sHouseCode As String, ByRef sPrompt As String) As Boolean
    Dim DetailRs As ADODB.Recordset
    Dim TempRs As ADODB.Recordset, rs As ADODB.Recordset
    Dim nAffected As Integer
    
    Dim sSqlStr As String, sFields As String, sValues As String
    Dim sDate As String, nFlag As Integer, sAbstract As String
    Dim InQuantity As Double, InMoney As Currency
    Dim BQuantity As Double, BPrice As Double, BMoney As Currency
    
    WaresInRecord = False
    sPrompt = ""
    
    sSqlStr = "Select InDetail.*, WaresList.FPriceMode From InDetail Inner Join WaresList On InDetail.FWaresCode = WaresList.FWaresCode Where FYear = " & nYear & " And FMonth = " & byMonth & " And FType = " & byType & " And FNo ='" & sNo & "' Order by Indetail.FWaresCode"
    Set DetailRs = New ADODB.Recordset
    DetailRs.Open sSqlStr, m_gDBCnn, adOpenStatic, adLockReadOnly, adCmdUnknown
    
    With DetailRs
        '更新结存量表
        Select Case byType
        Case IN_INVOICE, SURROGATE_INVOICE, BACK_INVOICE '入库单、代管入库单、商品退还单
            sSqlStr = "UPDATE Balance INNER JOIN InDetail ON Balance.FWaresCode = InDetail.FWaresCode SET Balance.FQuantity = Balance.FQuantity + InDetail.FQuantity "
        Case WASTAGE_INVOICE             '盘点单
            sSqlStr = "UPDATE Balance INNER JOIN InDetail ON Balance.FWaresCode = InDetail.FWaresCode SET Balance.FQuantity = Balance.FQuantity + FShortQuantity + FWearQuantity "
        End Select
        sSqlStr = sSqlStr & " Where Balance.FHouseCode = '" & sHouseCode & "' And FRecordLedger = 1 And FYear = " & nYear & " And FMonth = " & byMonth & " And FType = " & byType & " And FNo = '" & sNo & "'"
        m_gDBCnn.Execute sSqlStr, nAffected
        
        If nAffected <> .RecordCount Then
            Set rs = New ADODB.Recordset
            rs.Open "Select * From Balance Where FHouseCode = '" & sHouseCode & "' And FRecordLedger = 1 Order By FWaresCode", m_gDBCnn
            Do While Not .EOF
                rs.Filter = "FWaresCode = '" & ![FWaresCode] & "'"
                If rs.EOF Then
                    sPrompt = IIf(sPrompt = "", "", sPrompt & "、") & ![FWaresCode]
                End If
                .MoveNext
            Loop
            Set rs = Nothing
            sPrompt = "记帐不成功! 本单据以下商品没有完成期初: " & Chr(13) & sPrompt
            Exit Function
        End If
        
        '入库单、盘点单、商品退还单更新台帐表
        If byType = IN_INVOICE Or byType = WASTAGE_INVOICE Or byType = BACK_INVOICE Then
            sDate = Format(m_gLoginDate, "yyyy-mm-dd")
            Select Case byType
            Case IN_INVOICE
                sAbstract = "商品入库"
                nFlag = IN_HOUSE_DETAIL
            Case WASTAGE_INVOICE
                sAbstract = "盘库溢损"
                nFlag = IN_WASTAGE_DETAIL
            Case BACK_INVOICE
                sAbstract = "商品退还"
                nFlag = IN_BACK_DETAIL
            End Select
            
            Do While Not .EOF
                Set TempRs = New ADODB.Recordset
                sSqlStr = "Select Top 1 * From Ledger Where FHouseCode = '" & sHouseCode & "' And FWaresCode = '" & ![FWaresCode] & "' And FFlag < " & THIS_DAY_SUM & " Order by FId DESC"
                TempRs.Open sSqlStr, m_gDBCnn
                
                sFields = "Insert Into Ledger (FYear, FMonth, FHouseCode, FWaresCode, FNo, FFlag, FDate, FAbstract, FInQuantity, FInPrice, FInMoney, FBalanceQuantity, FBalancePrice, FBalanceMoney) "
                Select Case ![FPriceMode]
                Case FIFO_MODE, LIFO_MODE  '先进先出、后进先出
                    sValues = " Select " & ![FYear] & "," & ![FMonth] & ",'" & sHouseCode & "','" & ![FWaresCode] & "','" & ![FNo] & "'," & nFlag & ",#" & sDate & "#,'', 0, 0, 0, FBalanceQuantity, FBalancePrice, FBalanceMoney From Ledger " & _
                        " Where FYear = " & TempRs![FYear] & " And FMonth = " & TempRs![FMonth] & " And FHouseCode = '" & TempRs![Fhousecode] & "' And FWaresCode = '" & TempRs![FWaresCode] & "' And " & IIf(IsNull(TempRs![FNo]), "IsNull(FNo)", "FNo = '" & TempRs![FNo] & "'") & " And FFlag = " & TempRs![FFlag] & " And FBalanceQuantity > 0"
                    m_gDBCnn.Execute sFields & sValues
                    
                    If byType = IN_INVOICE Then
                        sValues = " Values (" & ![FYear] & "," & ![FMonth] & ",'" & sHouseCode & "','" & ![FWaresCode] & "','" & ![FNo] & "'," & nFlag & ",#" & sDate & "#,'', 0, 0, 0," & ![FQuantity] & "," & ![FPrice] & "," & ![FMoney] & ")"
                        m_gDBCnn.Execute sFields & sValues, nAffected
                        If nAffected <> 1 Then Exit Function
                        
                        sSqlStr = "Select * From Ledger Where FYear = " & ![FYear] & " And FMonth = " & ![FMonth] & " And FHouseCode = '" & sHouseCode & "' And FWaresCode = '" & ![FWaresCode] & "' And FNo = '" & ![FNo] & "' And FFlag = " & nFlag & " Order by FId"
                        Set rs = New ADODB.Recordset
                        rs.Open sSqlStr, m_gDBCnn, adOpenStatic, adLockOptimistic, adCmdUnknown
                        rs![FAbstract] = sAbstract
                        rs![FInQuantity] = ![FQuantity]
                        rs![FInPrice] = ![FPrice]
                        rs![FInMoney] = ![FMoney]
                        rs.Update
                        Set rs = Nothing
                    Else
                        If byType = WASTAGE_INVOICE Then
                            InQuantity = ![FShortQuantity] + ![FWearQuantity]
                            InMoney = ![FShortMoney] + ![FWearMoney]
                        ElseIf byType = BACK_INVOICE Then
                            InQuantity = ![FQuantity]
                            InMoney = ![FMoney]
                        End If
                        
                        Dim bRsEmpty As Boolean
                        bRsEmpty = True
                        sSqlStr = "Select * From Ledger Where FYear = " & ![FYear] & " And FMonth = " & ![FMonth] & " And FHouseCode = '" & sHouseCode & "' And FWaresCode = '" & ![FWaresCode] & "' And FNo = '" & ![FNo] & "' And FFlag = " & nFlag & " Order by FId"
                        Set rs = New ADODB.Recordset
                        rs.Open sSqlStr, m_gDBCnn, adOpenStatic, adLockOptimistic, adCmdUnknown
                        If Not (rs.EOF And rs.BOF) Then
                            bRsEmpty = False
                            rs![FAbstract] = sAbstract
                            rs![FInQuantity] = InQuantity
                            rs![FInPrice] = ![FPrice]
                            rs![FInMoney] = InMoney
                            rs.Update
                            
                            rs.Filter = "FBalancePrice = " & ![FPrice]
                            Do While Not rs.EOF And InQuantity <> 0
                                If rs![FBalanceQuantity] + InQuantity > 0 Then
                                    rs![FBalanceQuantity] = rs![FBalanceQuantity] + InQuantity
                                    rs![FBalanceMoney] = rs![FBalanceMoney] + InMoney
                                    rs.Update
                                    InQuantity = 0
                                    InMoney = 0
                                Else
                                    InQuantity = InQuantity + rs![FBalanceQuantity]
                                    InMoney = InMoney + rs![FBalanceMoney]
                                    rs![FBalanceQuantity] = 0
                                    rs![FBalanceMoney] = 0
                                    rs.Update
                                End If
                                rs.MoveNext
                            Loop
                            Set rs = Nothing
                        End If
                        
                        If InQuantity <> 0 Then
                            If byType = WASTAGE_INVOICE And InQuantity > 0 Then
                                If bRsEmpty Then    '历史无结存
                                    sValues = "'" & sAbstract & "'," & InQuantity & "," & ![FPrice] & "," & InMoney
                                Else                '历史有结存，摘要、入数量、单价、金额以写至相应第一条记录
                                    sValues = "'', 0, 0, 0"
                                End If
                                sValues = " Values (" & ![FYear] & "," & ![FMonth] & ",'" & sHouseCode & "','" & ![FWaresCode] & "','" & ![FNo] & "'," & nFlag & ",#" & sDate & "#," & sValues & "," & InQuantity & "," & ![FPrice] & "," & InMoney & ")"
                                m_gDBCnn.Execute sFields & sValues, nAffected
                                If nAffected <> 1 Then Exit Function
                            Else
                                If sPrompt <> "" Then sPrompt = sPrompt & "、"
                                sPrompt = sPrompt & ![FWaresCode]
                            End If
                        End If
                    End If
                    
                Case WEIGHT_AVER_MODE, MOVE_AVER_MODE   '加权平均、移动平均
                    If byType = IN_INVOICE Or byType = BACK_INVOICE Then
                        InQuantity = ![FQuantity]
                        InMoney = ![FMoney]
                    ElseIf byType = WASTAGE_INVOICE Then
                        InQuantity = ![FShortQuantity] + ![FWearQuantity]
                        InMoney = ![FShortMoney] + ![FWearMoney]
                    End If
                    
                    If (byType = WASTAGE_INVOICE Or byType = BACK_INVOICE) And InQuantity + TempRs![FBalanceQuantity] < 0 Then
                        If sPrompt <> "" Then sPrompt = sPrompt & "、"
                        sPrompt = sPrompt & ![FWaresCode]
                    End If
                    
                    If ![FPriceMode] = MOVE_AVER_MODE Then
                        BQuantity = InQuantity + TempRs![FBalanceQuantity]
                        BMoney = InMoney + TempRs![FBalanceMoney]
                        BPrice = Format(IIf(BQuantity = 0, TempRs![FbalancePrice], BMoney / BQuantity), PriceFormat())
                    Else        'WEIGHT_AVER_MODE
                        BQuantity = InQuantity + TempRs![FBalanceQuantity]
                        BMoney = 0
                        BPrice = 0
                    End If
                    
                    sValues = " Values (" & ![FYear] & "," & ![FMonth] & ",'" & sHouseCode & "','" & ![FWaresCode] & "','" & ![FNo] & "'," & nFlag & ",#" & sDate & "#,'" & sAbstract & "'," & InQuantity & "," & ![FPrice] & "," & InMoney & "," & BQuantity & "," & BPrice & "," & BMoney & ")"
                    m_gDBCnn.Execute sFields & sValues, nAffected
                    If nAffected <> 1 Then Exit Function
                End Select
                Set TempRs = Nothing
                .MoveNext
            Loop
            
            If (byType = WASTAGE_INVOICE Or byType = BACK_INVOICE) And sPrompt <> "" Then
                sPrompt = "记帐不成功，以下商品记帐后将导致结存数量出现负数：" & Chr(13) & Space(4) & sPrompt
                Exit Function
            End If
        End If
    End With
    Set DetailRs = Nothing
    WaresInRecord = True
End Function

'///////////////////////////////////////////
'//
Function CalculatePrice(sWarescode As String, sHouseCode As String, dblQuantity As Double, nPriceMode As Integer, sNo As String, ByRef MoneySum As Currency) As Boolean
''//WaresList表中FPriceMode定义:
'Public Const FIFO_MODE = 0              '先进先出
'Public Const WEIGHT_AVER_MODE = 1       '加权平均
'Public Const MOVE_AVER_MODE = 2         '移动平均
'Public Const LIFO_MODE = 3              '后进先出
'm_gnYear = 1999
'm_gbyMonth = 9
'm_gLoginDate = Date
Dim tempQuantity As Double
tempQuantity = dblQuantity
On Error GoTo Data_Err:
MoneySum = 0
Dim LedgerRs As New ADODB.Recordset
    Dim sTempNo As String
    Dim dblOldQuantity As Double, dblOldPrice As Double, curOldMoney As Currency
    Dim RecPos As Long
    Dim nTempFlag As Integer
    Dim bFirstRecord As Boolean
    bFirstRecord = True
Select Case nPriceMode
    Case FIFO_MODE, LIFO_MODE
    
    LedgerRs.Open "select Fno,FFlag from ledger where FhouseCode='" & sHouseCode & "' and FWaresCode = '" & sWarescode & "' and FFlag <" & THIS_DAY_SUM & " order by FId", m_gDBCnn, adOpenStatic, adLockReadOnly
    If Not (LedgerRs.EOF And LedgerRs.BOF) Then
        LedgerRs.MoveLast
        sTempNo = IIf(IsNull(LedgerRs!FNo), "NULL", LedgerRs!FNo)
        nTempFlag = LedgerRs!FFlag
    Else
        MsgBox "应用程序出错,请与供应商联系"
        Exit Function
    End If
    LedgerRs.Close
    
    Dim DuplicateRs As ADODB.Recordset
    Dim strTempSQL As String
    Set DuplicateRs = New ADODB.Recordset
    DuplicateRs.CursorLocation = adUseClient
    If sTempNo = "NULL" Then
        strTempSQL = "select * from ledger where FhouseCode='" & sHouseCode & "' and FWaresCode = '" & sWarescode & "' and isNULL(FNo) and FFlag =" & nTempFlag & " order by FId"
        
    Else
        strTempSQL = "select * from ledger where FhouseCode='" & sHouseCode & "' and FWaresCode = '" & sWarescode & "' and FNo = '" & sTempNo & "' and FFlag =" & nTempFlag & " order by FId"
    End If
    DuplicateRs.Open strTempSQL, m_gDBCnn, adOpenStatic, adLockOptimistic

    
    LedgerRs.CursorLocation = adUseClient
    LedgerRs.Open "select * from ledger where FhouseCode='" & sHouseCode & "' and FWaresCode = '" & sWarescode & "' and FNo = '" & sNo & "'and FFlag =" & OUT_HOUSE_DETAIL & " order by FId", m_gDBCnn, adOpenStatic, adLockOptimistic

    
    If nPriceMode = LIFO_MODE Then DuplicateRs.MoveLast
    Do While dblQuantity >= DuplicateRs!FBalanceQuantity
        LedgerRs.AddNew
        LedgerRs!FOutQuantity = DuplicateRs!FBalanceQuantity
        LedgerRs!FOutPrice = DuplicateRs!FbalancePrice
        LedgerRs!FOutMoney = DuplicateRs!FBalanceMoney
        MoneySum = MoneySum + LedgerRs!FOutMoney
        LedgerRs!FYear = m_gnYear
        LedgerRs!FMonth = m_gbyMonth
        LedgerRs!Fhousecode = sHouseCode
        LedgerRs!FWaresCode = sWarescode
        LedgerRs!FNo = sNo
       ' LedgerRs!FAbstract = "商品出库"
        If bFirstRecord Then
            LedgerRs!FAbstract = "商品出库"
            bFirstRecord = False
        End If
        LedgerRs!FDate = m_gLoginDate
        LedgerRs!FFlag = OUT_HOUSE_DETAIL

        LedgerRs.Update
        
        dblQuantity = dblQuantity - DuplicateRs!FBalanceQuantity
        
       
        If nPriceMode = LIFO_MODE Then
            DuplicateRs.MovePrevious
        Else
            DuplicateRs.MoveNext
        End If
        '如果没有结存, 则直接到修改balance 表
        If DuplicateRs.EOF Or DuplicateRs.BOF Then GoTo Edit_Balance
    Loop
    If dblQuantity = 0 Then
    
    ElseIf dblQuantity > 0 Then
        LedgerRs.AddNew
        LedgerRs!FOutQuantity = dblQuantity
        LedgerRs!FOutPrice = DuplicateRs!FbalancePrice
        LedgerRs!FOutMoney = Format(dblQuantity * DuplicateRs!FbalancePrice, MoneyFormat())
        MoneySum = MoneySum + LedgerRs!FOutMoney
        LedgerRs!FYear = m_gnYear
        LedgerRs!FMonth = m_gbyMonth
        LedgerRs!Fhousecode = sHouseCode
        LedgerRs!FWaresCode = sWarescode
        LedgerRs!FNo = sNo
        'LedgerRs!FAbstract = "商品出库"
        LedgerRs!FDate = m_gLoginDate
        LedgerRs!FFlag = OUT_HOUSE_DETAIL
        LedgerRs.Update
    
    End If
    '因为FId 的缘故,必须刷新记录集,否则记录集无法定位
    LedgerRs.Requery
    LedgerRs.MoveFirst
    
    Dim bFisrtRec As Boolean
    bFisrtRec = True
    
    If nPriceMode = FIFO_MODE Then
    
        Do While Not DuplicateRs.EOF
            If Not LedgerRs.EOF Then  'IsNull(LedgerRs!FoutQuantity)
                If bFisrtRec Then
                    LedgerRs!FBalanceQuantity = DuplicateRs!FBalanceQuantity - dblQuantity
                    bFisrtRec = False
                Else
                    LedgerRs!FBalanceQuantity = DuplicateRs!FBalanceQuantity
                End If
                LedgerRs!FbalancePrice = DuplicateRs!FbalancePrice
                LedgerRs!FBalanceMoney = Format(LedgerRs!FBalanceQuantity * LedgerRs!FbalancePrice, MoneyFormat())
                LedgerRs.Update
                LedgerRs.MoveNext
            Else
                LedgerRs.AddNew
                LedgerRs!FBalanceQuantity = DuplicateRs!FBalanceQuantity
                LedgerRs!FbalancePrice = DuplicateRs!FbalancePrice
                LedgerRs!FBalanceMoney = DuplicateRs!FBalanceMoney
                
                LedgerRs!FYear = m_gnYear