ledgermodule.bas

针对农资系统的管理模式而开发的业务部门与财务部门的转账模式和过程

Attribute VB_Name = "LedgerModule"
Option Explicit

Public Sub MonthEnd()
'月末结账
'先检查是否有没有记帐的单据
Dim rs As ADODB.Recordset
Set rs = New ADODB.Recordset
rs.Open "select FCloseAccDate from system", m_gDBCnn, adOpenStatic, adLockOptimistic
If rs!FCloseAccDate < m_gLoginDate Then
    
    If vbOK = MsgBox("月结以后不能再录入本月数据,您确定要月结吗?", vbOKCancel, "月末结帐") Then
        m_gMainForm.MousePointer = vbHourglass
        If PeriodEndKeepRecord Then
            rs!FCloseAccDate = GetCloseDay(False, m_gnYear, m_gbyMonth)
            rs.Update
            End  '应该重新登陆
        End If
        m_gMainForm.MousePointer = 0
        
    End If
Else
    MsgBox "本月已经结帐"
End If
rs.Close
End Sub

Public Sub RollBackMonthEnd()
'退回月结
 'if m_glogin
 Dim CloseAccDate As Date
 Dim BulidAccDate As Date
 Dim rs As ADODB.Recordset
 Set rs = New ADODB.Recordset
 rs.Open "select FCloseAccDate,FBuildAccDate from system", m_gDBCnn, adOpenStatic, adLockOptimistic
 CloseAccDate = rs!FCloseAccDate
 BulidAccDate = rs!FBuildAccDate
 rs.Close
 rs.Open "select FYear,Fmonth,FDate from ledger where FDate >#" & CloseAccDate & "# and FFlag > " & PREV_MONTH_CLOSE & " and FFlag <13", m_gDBCnn, adOpenStatic, adLockReadOnly
 If rs.EOF And rs.BOF Then
    Dim strSQL As String
    If m_gbyMonth > 1 Then
        strSQL = "delete from ledger where FYear = " & m_gnYear & " and Fmonth>= " & m_gbyMonth - 1 & " and ( FFlag <=1 or FFlag>=13)"
    Else
        If m_gnYear > Year(BulidAccDate) Then
            strSQL = "delete from ledger where Fdate >=# " & CloseAccDate & "# and ( FFlag <=1 or FFlag>=13)"
        Else
            MsgBox "没有进行过月结,没有月结可退"
            Exit Sub
        End If
    
    End If
    m_gDBCnn.Execute strSQL
    strSQL = "update system set FCloseAccDate = #" & GetCloseDay(False, m_gnYear, m_gbyMonth - 2) & "#"
    m_gDBCnn.Execute strSQL
    MsgBox "成功退回到本月月结前的状态."
    End
 Else
    MsgBox "已经录入下月数据,不能退回!"
 End If
End Sub
Function PeriodEndKeepRecord() As Boolean
Dim CurrentMonth  As String
Dim CurrentYear As String
Dim CurrentDate As String
CurrentYear = m_gnYear 'GetPrivateSetting("operator", "CurrentYear", "0")
CurrentMonth = m_gbyMonth 'GetPrivateSetting("operator", "CurrentMonth", "0")
CurrentDate = GetCloseDay(False, m_gnYear, m_gbyMonth)  'GetPrivateSetting("operator", "CurrentMonthEnd", "0")
If CurrentYear = "0" Or CurrentMonth = "0" Or CurrentDate = "0" Then
    MsgBox "由帐表传递的结帐日期有误!,不能结帐"
End If
'（1） 检查所有没有记帐的原始凭证（不含代管入出库单、商品损耗单）
'加权
Dim strSQL As String
Dim TableName(4) As String
Dim sFTypeFilter(4) As String
Dim nNextYear As Integer
Dim nNextMonth As Integer
Dim NextDate As Date
If Val(CurrentMonth) = 12 Then
    nNextMonth = 1
    nNextYear = Val(CurrentYear + 1)
Else
    nNextMonth = Val(CurrentMonth) + 1
    nNextYear = Val(CurrentYear)
End If
NextDate = Str(nNextYear) & "/" & Str(nNextMonth) & "/01 "
TableName(0) = "Sell"
sFTypeFilter(0) = ""
TableName(1) = "Stockup"
sFTypeFilter(1) = ""
TableName(2) = "WaresIn"
sFTypeFilter(2) = "And FType <> SURROGATE_INVOICE "
TableName(3) = "WaresOut"
sFTypeFilter(3) = "And  FType <> OUT_OTHER "
'On Error GoTo KeepRecordErr
Dim i  As Integer
m_gDBCnn.BeginTrans
'For i = 0 To 3
'strSQL = "update  " & TableName(i) & _
'" set FYear =" & nNextYear & ",FMonth = " & nNextMonth & ",Fdate=#" & NextDate & "# " & _
'"where Fkeeper ='' or  isnull(Fkeeper) " & sFTypeFilter(i)
''m_gDBCnn.Execute strSQL
'Next i



'，改变原始凭证上的年、月及日期，日期为下个财务月首日
'（2） 按商品计价方法在所有库存商品明细帐上分别写本月合计、上月结转或上年结转（12月）、本季合计（3、6、9、12月）、本年合计,结转下年（12月），填写方法如下：
Dim rs As ADODB.Recordset
Set rs = New ADODB.Recordset

strSQL = "SELECT distinct Ledger.FHouseCode, Ledger.FWaresCode, WaresList.FPriceMode" & _
" FROM Ledger INNER JOIN WaresList ON Ledger.FWaresCode = WaresList.FWaresCode "
rs.Open strSQL, m_gDBCnn, adOpenStatic, adLockReadOnly
If rs.EOF And rs.BOF Then
    MsgBox "没有可结转的数据"
    Exit Function
End If
Dim result As Boolean

Do While Not rs.EOF
    Select Case CurrentMonth
    Case 1, 2, 4, 5, 7, 8, 10, 11
    result = KeepRecordMonth(rs!Fhousecode, rs!FWaresCode, rs!FPriceMode, CurrentYear, CurrentMonth, CurrentDate, 1)
    If Not result Then GoTo KeepRecordErr
    result = KeepRecordMonth(rs!Fhousecode, rs!FWaresCode, rs!FPriceMode, CurrentYear, CurrentMonth, CurrentDate, 4)
    If Not result Then GoTo KeepRecordErr
    Case 3, 6, 9
    result = KeepRecordMonth(rs!Fhousecode, rs!FWaresCode, rs!FPriceMode, CurrentYear, CurrentMonth, CurrentDate, 1)
    If Not result Then GoTo KeepRecordErr
    result = KeepRecordMonth(rs!Fhousecode, rs!FWaresCode, rs!FPriceMode, CurrentYear, CurrentMonth, CurrentDate, 2)
    If Not result Then GoTo KeepRecordErr
    result = KeepRecordMonth(rs!Fhousecode, rs!FWaresCode, rs!FPriceMode, CurrentYear, CurrentMonth, CurrentDate, 4)
    If Not result Then GoTo KeepRecordErr
    Case 12
    result = KeepRecordMonth(rs!Fhousecode, rs!FWaresCode, rs!FPriceMode, CurrentYear, CurrentMonth, CurrentDate, 1)
    If Not result Then GoTo KeepRecordErr
    result = KeepRecordMonth(rs!Fhousecode, rs!FWaresCode, rs!FPriceMode, CurrentYear, CurrentMonth, CurrentDate, 2)
    If Not result Then GoTo KeepRecordErr
    result = KeepRecordMonth(rs!Fhousecode, rs!FWaresCode, rs!FPriceMode, CurrentYear, CurrentMonth, CurrentDate, 3)
    If Not result Then GoTo KeepRecordErr
    result = KeepRecordMonth(rs!Fhousecode, rs!FWaresCode, rs!FPriceMode, CurrentYear, CurrentMonth, CurrentDate, 6)
    If Not result Then GoTo KeepRecordErr
    result = KeepRecordMonth(rs!Fhousecode, rs!FWaresCode, rs!FPriceMode, CurrentYear, CurrentMonth, CurrentDate, 5)
    If Not result Then GoTo KeepRecordErr
    End Select
    
    rs.MoveNext
Loop
CollectMonth
m_gDBCnn.CommitTrans
MsgBox "结转帐完毕!"
PeriodEndKeepRecord = True
Exit Function
KeepRecordErr:
    m_gDBCnn.RollbackTrans
    MsgBox "结转帐出错!"
    PeriodEndKeepRecord = False
End Function
'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
'PREV_MONTH_CLOSE=1 上月结转
'Public Const THIS_MONTH_SUM As Integer = 14     '本月合计
'Public Const THIS_SEASON_TOTAL As Integer = 15  '本季累计
'Public Const THIS_YEAR_TOTAL As Integer = 16    '本年累计
'Public Const THIS_SEASON_SUM As Integer = 17    '本季合计
'Public Const THIS_YEAR_SUM As Integer = 18      '本年合计
'Public Const CLOSE_NEXT_YEAR As Integer = 19    '结转下年
Function KeepRecordMonth(sHouseCode As String, sWarescode As String, nPriceMode As Integer, ByVal sYear As String, ByVal sMonth As String, sDate As String, nSumType As Integer) As Boolean
Dim rs As ADODB.Recordset
Set rs = New ADODB.Recordset
Dim strSQL As String
Dim nFlag As Integer
Dim strAbstract As String
Dim strSumFilter As String
Select Case nSumType
Case 1  '本月合计
    nFlag = THIS_MONTH_SUM
    strAbstract = "本月合计"
    strSumFilter = " FYear = " & sYear & " and Fmonth =" & sMonth
  
Case 2  '本季合计
    nFlag = THIS_SEASON_SUM
    strAbstract = "本季合计"
    strSumFilter = " FYear = " & Val(sYear) & " and Fmonth >= " & (Val(sMonth) - 2) & " and fmonth <=" & Val(sMonth)
Case 3  '本年合计
    nFlag = THIS_YEAR_SUM
    strAbstract = "本年合计"
    strSumFilter = " FYear = " & sYear
Case 4 '上月结转
    nFlag = PREV_MONTH_CLOSE
    strAbstract = "上月结转"
    strSumFilter = " FYear = " & sYear & " and Fmonth =" & sMonth
   
Case 5 '上年结转
    nFlag = PREV_YEAR_CLOSE
    strAbstract = "上年结转"
    strSumFilter = " FYear = " & sYear
Case 6 '结转下年
    nFlag = CLOSE_NEXT_YEAR
    strAbstract = "结转下年"
    strSumFilter = " FYear = " & sYear

End Select
'On Error GoTo KeepErr:

'本月合计
strSQL = "SELECT Sum(Ledger.FInQuantity) AS SumInQuantity, Sum(Ledger.FInMoney) AS SumInMoney, Sum(Ledger.FOutQuantity) AS SumOutQuantity, Sum(Ledger.FOutMoney) AS SumOutMoney, Sum(Ledger.FDiaoBoInMoney) AS SumDiaoBoInMoney, Sum(Ledger.FDiaoBoInQuantity) AS SumDiaoBoInQuantity, Sum(Ledger.FDiaoBoOutQuantity) AS SumDiaoBoOutQuantity, Sum(Ledger.FDiaoBoOutMoney) AS SumDiaoboOutMoney FROM Ledger " & _
 "where FHouseCode = '" & sHouseCode & "' and FWaresCode = '" & sWarescode & "' and FFlag >1 and FFlag <13 and"
 
 strSQL = strSQL & strSumFilter
rs.Open strSQL, m_gDBCnn, adOpenStatic, adLockReadOnly
If IsNull(rs!SuminQuantity) And IsNull(rs!SumOutQuantity) And (nSumType < 4 Or nSumType = 6) Then
    
        KeepRecordMonth = True
        Exit Function
    
Else
    If nSumType = 6 Then '结转下年
        strSQL = "insert into ledger  (FYear,Fmonth,FHouseCode,FWaresCode,FFlag,FDate,FAbstract,FOutQuantity,FOutMoney,FInquantity,FInMoney)" & _
              " select  " & Val(sYear) & "," & Val(sMonth) & ",'" & sHouseCode & "','" & sWarescode & "'," & nFlag & ",#" & sDate & "#,'" & strAbstract & "'," & rs!SuminQuantity & "," & rs!SuminMoney & ", " & rs!SumOutQuantity & "," & rs!SumOutMoney
        m_gDBCnn.Execute strSQL
        KeepRecordMonth = True
        Exit Function
    End If
   '先写结存
   Dim tempQuantity As Double
        Dim tempMoney As Currency
        Dim tempPrice As Double
    Dim rs2 As ADODB.Recordset
        Set rs2 = New ADODB.Recordset
       
            strSQL = "select * from ledger where  FHouseCode ='" & sHouseCode & "' and FWaresCode ='" & sWarescode & "' order by fid"
       
        rs2.Open strSQL, m_gDBCnn, adOpenStatic, adLockOptimistic
        
   Select Case nPriceMode
   Case FIFO_MODE, LIFO_MODE '0,3
        Dim Rs1 As ADODB.Recordset
        Set Rs1 = New ADODB.Recordset  ',FAbstract,FInquantity,FInMoney,FOutQuantity,FOutMoney,
        If nSumType < 4 Then
            strSQL = "select * from ledger where " & strSumFilter & " and FFlag>1 and Fflag<13 and FWaresCode='" & sWarescode & "' and FHouseCode='" & sHouseCode & "' And FAbstract <>'' and not isnull(FAbstract)"
        Else
            strSQL = "select * from ledger where " & strSumFilter & " and  Fflag<13 and FWaresCode='" & sWarescode & "' and FHouseCode='" & sHouseCode & "' And FAbstract <>'' and not isnull(FAbstract)"
        End If
        Rs1.Open strSQL, m_gDBCnn, adOpenStatic, adLockReadOnly
        Rs1.MoveLast
        If nSumType = 4 Then '上月结转
           sMonth = Format(Val(sMonth) + 1)
           sDate = sYear & "/" & sMonth & "/01"
        ElseIf nSumType = 5 Then ' 上年结转
           sMonth = "01"
           sYear = Format(Val(sYear) + 1)
           sDate = sYear & "/" & sMonth & "/01"
        End If
        strSQL = "insert into ledger (FYear,Fmonth,FHouseCode,FWaresCode,FFlag,FDate,FBalancequantity,FBalancePrice,FBalanceMoney) " & _
        "select  " & Val(sYear) & "," & Val(sMonth) & ",'" & sHouseCode & "','" & sWarescode & "'," & nFlag & ",#" & sDate & "#,FBalancequantity,FBalancePrice,FBalanceMoney from Ledger " & _
        " where FHouseCode ='" & sHouseCode & "' and FWaresCode ='" & sWarescode & "' and FFlag=" & Rs1!FFlag & " and " & IIf(IsNull(Rs1!FNo), "isNULL(Fno)", "fno='" & Rs1!FNo & "'") & " and FBalanceQuantity<>0"
        Dim RecordsAffected  As Integer
        

        m_gDBCnn.Execute strSQL, RecordsAffected
        Rs1.Close
        strSQL = "select * from Ledger Where  FHouseCode ='" & sHouseCode & "' and FWaresCode ='" & sWarescode & "' and FFlag=" & nFlag & " and FYear =" & Val(sYear) & " and Fmonth=" & Val(sMonth)
        Rs1.Open strSQL, m_gDBCnn, adOpenStatic, adLockOptimistic
        Rs1!FAbstract = strAbstract
        If nSumType < 4 Then
            If Not IsNull(rs!SuminQuantity) Then
                Rs1!FInQuantity = rs!SuminQuantity
                Rs1!FInMoney = rs!SuminMoney
            End If
            If Not IsNull(rs!SumOutQuantity) Then
                Rs1!FOutQuantity = rs!SumOutQuantity
                Rs1!FOutMoney = rs!SumOutMoney
            End If
        End If
        Rs1.Update
        Rs1.Close
        
   Case WEIGHT_AVER_MODE '1 加权平均
        Dim CurLastBalanceMoney As Currency '上期结存金额
        Dim CurLastBalanceQuantity As Double '上期结存数量
        
        '过滤为上月结转或上年结转
        If nSumType <> 4 And nSumType <> 5 Then
            rs2.Filter = "FFlag= " & PREV_MONTH_CLOSE & " or  FFlag = " & PREV_YEAR_CLOSE    'THIS_MONTH_SUM,PREV_YEAR_CLOSE,PREV_MONTH_CLOSE