frmclosecost.frm

金算盘软件代码

        Set recVoucher = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
        Do While Not recVoucher.EOF
            If recVoucher!bytPeriod > 0 And recVoucher!bytPeriod < msgPeriod.Rows Then
                msgPeriod.TextMatrix(recVoucher!bytPeriod, 3) = "√"
                msgPeriod.TextMatrix(recVoucher!bytPeriod, 5) = recVoucher!strDate
                If recVoucher!lngPostID > 0 Then
                    msgPeriod.TextMatrix(recVoucher!bytPeriod, 1) = recVoucher!lngVoucherID * (-1)
                Else
                    msgPeriod.TextMatrix(recVoucher!bytPeriod, 1) = recVoucher!lngVoucherID
                End If
            End If
            recVoucher.MoveNext
        Loop
        recVoucher.Close
        
        If gclsBase.AccountYear = mintStartYear Then
            msgPeriod.ColAlignment(3) = 4
            For lngCnt = 1 To mintStartPeriod - 1
                msgPeriod.TextMatrix(lngCnt, 3) = "—"
            Next lngCnt
        End If
        
        msgPeriod.col = 2
        If gclsBase.Period > 0 And gclsBase.Period < msgPeriod.Rows Then
            msgPeriod.Row = gclsBase.Period
        Else
            If msgPeriod.Rows > msgPeriod.FixedRows Then
                msgPeriod.Row = msgPeriod.FixedRows
            End If
        End If
        
        '计算最小成本计算日期
        mintMinPeriod = 0
        strSql = "SELECT MIN(Item.strReCalcCost) AS strReCalcCost " _
            & "FROM Item ,ItemNature WHERE Item.lngItemNatureID=ItemNature.lngItemNatureID " _
            & "AND strItemCategory='1' AND blnIsCalcCost = 0 "
        Set recItem = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
        If IsDate(recItem!strReCalcCost) Then
           mintMinPeriod = gclsBase.PeriodOfDate(CDate(recItem!strReCalcCost))
        Else
            mintMinPeriod = 100  '所有期间成本都已计算
        End If
        recItem.Close
        
        msgPeriod.col = 0
        msgPeriod.ColSel = 5
    End If
End Sub

'第二步: 凭证选项初始
Private Function InitOption()
    Dim strSql As String
    
    If fraWizard(1).Tag <> "已设置" Then
        
        fraWizard(1).Tag = "已设置"

        '凭证模板参照
        RefreshTemplate
    
        '凭证类型参照
        RefreshVoucherType
    End If
End Function

'第三步：凭证预缆初始
Private Function InitResult()
    Dim lngCnt As Long, lngCntDetail As Long
    Dim strResult As String, strDetail As String, strAmount As String
    Dim strSql As String
    Dim recAccount As rdoResultset
    Dim lngLen As Long, lngSpace As Long
    
    If fraWizard(2).Tag <> "已设置" Then
        
        fraWizard(2).Tag = "已设置"
        
        '摘要参照
        RefreshRemark
        lstxtRemark.Text = "结转成本[商品性质]"
        
        '生成凭证
        GenCostVoucher
        If Not VoucherData(0).Used Then Exit Function
        If Not VoucherData(0).IsError Then
            ValidVoucher VoucherData(0)
        End If
        If VoucherData(0).IsError Then
            ShowMsg hwnd, VoucherData(0).ErrorString, vbCritical + vbOKOnly, Caption
            Exit Function
        End If
        
        strResult = ""
        lngLen = 48
            
        If UBound(VoucherData(0).Detail) < 100 Then
            With VoucherData(0)
                For lngCntDetail = 0 To UBound(.Detail)
                    If .Detail(lngCntDetail).Direction = adDebit Then
                        strDetail = "借："
                    Else
                        strDetail = "贷："
                    End If
                    strSql = "SELECT strAccountCode,strAccountName FROM Account " _
                        & "WHERE lngAccountID=" & .Detail(lngCntDetail).AccountID
                    Set recAccount = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
                    If Not recAccount.EOF Then
                        strDetail = strDetail & recAccount!strAccountCode & " " _
                            & Trim(recAccount!strAccountName)
                    End If
                    lngSpace = 34 - StrLen(strDetail)
                    If lngSpace < 0 Then lngSpace = 0
                    strDetail = strDetail & Space(lngSpace)
                    strAmount = Format(.Detail(lngCntDetail).Amount, "#0.00")
                    lngSpace = 14 - StrLen(strAmount)
                    If lngSpace < 0 Then lngSpace = 0
                    strDetail = strDetail & Space(lngSpace) & strAmount
                    strResult = strResult & strDetail & Chr(13) & Chr(10)
                Next lngCntDetail
            End With
            strResult = strResult & "────────────────────────" & Chr(13) & Chr(10)
        Else
            strResult = "凭证共有" & UBound(VoucherData(0).Detail) + 1 & "笔分录"
        End If
        txtResult.Text = strResult
    End If
End Function


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
'  向导步骤合法检查
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'第一步：会计期间合法检查
Private Function ValidPeriod(Msg As String) As Boolean
    Dim lngRow As Long
    Dim recTmp As rdoResultset
    Dim strSql As String
    Dim dtmStart As Date, dtmEnd As Date
    
    ValidPeriod = True
    
    '短开绑定数据
    Set datPeriod.Resultset = Nothing
    
    With msgPeriod
        If .ColSel <= .col Or (Not IsNumeric(Mid(.TextMatrix(.Row, 2), 1, 4))) Or (Not IsNumeric(Mid(.TextMatrix(.Row, 2), 6, 2))) Then
            ValidPeriod = False
            Msg = "请指定会计期间！"
        Else
            mintPeriod = CLng(Mid(.TextMatrix(.Row, 2), 6, 2))
        End If
    End With
    
    If gclsBase.AccountYear = mintStartYear And mintPeriod < mintStartPeriod Then
        ValidPeriod = False
        Msg = "指定会计期间不能小于帐套启用期间！"
    End If
    
    '检查上月是否结帐成本
    If ValidPeriod Then
        If mintYear <> gclsBase.AccountYear And mintPeriod <> mintStartPeriod Then
            If msgPeriod.Row > msgPeriod.FixedRows Then
                lngRow = msgPeriod.Row
                If msgPeriod.TextMatrix(lngRow - 1, 4) <> "√" Then
                    If msgPeriod.TextMatrix(lngRow - 1, 3) <> "√" Then
                        Msg = "上月未结转成本差异(进销差价)。若没有数据可结转，请先结帐！"
                        ValidPeriod = False
                    End If
                End If
            End If
        End If
    End If
    
    '检查本月是否结帐
    If ValidPeriod Then
        With msgPeriod
            If .TextMatrix(.Row, 4) = "√" Then
                ValidPeriod = False
                Msg = "本月已经结帐，不能再转成本差异(进销差价)！"
            End If
        End With
    End If
    
    '检查本月是否需要重新计算成本
    If ValidPeriod Then
        '取本会计期间的起止日期
        gclsBase.DateOfPeriod mintYear, mintPeriod, dtmStart, dtmEnd
        strSql = "SELECT lngItemID FROM ItemActivityDetail,ItemActivity " _
            & "WHERE ItemActivityDetail.lngActivityID=ItemActivity.lngActivityID " _
            & "AND strDate>='" & Format(dtmStart, "yyyy-mm-dd") & "' " _
            & "AND strDate<='" & Format(dtmEnd, "yyyy-mm-dd") & "' " _
            & "AND lngItemID IN (SELECT lngItemID FROM Item,ItemNature " _
            & "WHERE Item.lngItemNatureID=ItemNature.lngItemNatureID " _
            & "AND strItemCategory='1')"

        Set recTmp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
        If Not recTmp.EOF Then
            If mintPeriod > mintMinPeriod Then
                ValidPeriod = False
                Msg = "本月需要重新计算成本！"
            End If
        Else
            ValidPeriod = False
            Msg = "本月没有成本差异(进销差价)可结转！"
        End If
        recTmp.Close
    End If
    
    '检查本月是否结转成本
    If ValidPeriod Then
        With msgPeriod
            If .TextMatrix(.Row, 3) = "√" Then
                ValidPeriod = False
                Msg = "本月已经结转成本差异(进销差价)，不能再转！"
            End If
        End With
    End If
    fraWizard(2).Tag = ""
End Function

'第二步，凭证选项
Private Function ValidOption(Msg As String) As Boolean
    Dim strSql As String
    Dim recTmp As rdoResultset
    Dim strCode As String, strText As String
    
    ValidOption = True
    
    strText = lstxtTemplate.Text
    If InStr(strText, vbTab) > 0 Then
        strCode = Left(strText, InStr(strText, vbTab) - 1)
    Else
        If InStr(strText, " ") > 0 Then
            strCode = Left(strText, InStr(strText, " ") - 1)
        Else
            strCode = Trim(strText)
        End If
    End If
    If strCode = "" Then
        ValidOption = False
        Msg = "请输入凭证模板！"
    End If
    
    If ValidOption Then
        If lstxtTemplate.ID = 0 Then
            Msg = "凭证模板不存在！"
            ValidOption = False
        End If
    End If
    
    If ValidOption Then
        strText = lstxtType.Text
        If InStr(strText, vbTab) > 0 Then
            strCode = Left(strText, InStr(strText, vbTab) - 1)
        Else
            If InStr(strText, " ") > 0 Then
                strCode = Left(strText, InStr(strText, " ") - 1)
            Else
                strCode = Trim(strText)
            End If
        End If
        If strCode = "" Then
            ValidOption = False
            Msg = "请输入凭证类型！"
        End If
    End If
    
    If ValidOption Then
        strSql = "SELECT lngVoucherTypeID FROM VoucherType " _
            & "WHERE strVoucherTypeCode='" & strCode & "'"
        Set recTmp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
        If recTmp.EOF Then
            Msg = "凭证类型不存在！"
            ValidOption = False
        Else
            mVoucherTypeID = recTmp!lngVoucherTypeID
            fraWizard(2).Tag = ""
        End If
        recTmp.Close
    End If
    
End Function

'第三步，凭证预览
Private Function ValidResult(Msg As String) As Boolean
    ValidResult = True
    
    If ValidResult Then
        If lstxtRemark.Text = "" Then
            ValidResult = False
            Msg = "未指定凭证摘要！"
        End If
    End If
    
    If ValidResult Then
'        GenCostVoucher
    End If
End Function


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' 其他过程
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'卡片新增（模板）
Private Sub lstxtTemplate_Choose()
    mTemplateID = lstxtTemplate.TextMatrix(lstxtTemplate.ReferRow, 1)
End Sub
Private Sub lstxtTemplate_AddNew()
    mTemplateID = FrmNewTemplate.AddCard(, 1, 17, mlngFormatID, lstxtTemplate.ID)
    RefreshTemplate mTemplateID
End Sub
Private Sub lstxtTemplate_Delete()
    If mTemplateID > 0 Then
        If Card.DelCard(msgTemplate, mTemplateID) Then
            RefreshTemplate
        End If
    End If
End Sub
Private Sub lstxtTemplate_Edit()
    If mTemplateID > 0 Then
       Card.EditCard msgTemplate, mTemplateID, , mlngFormatID
       RefreshTemplate mTemplateID
    End If
End Sub
Private Sub lstxtTemplate_ItemNotExist()
    Dim lngID As Long
    If frmMsgAdd.MsgAddShow("增加凭证模板", "凭证模板“" & Trim(lstxtTemplate.Text) & "”不存在，是否新增?") = vbOK Then
        lngID = FrmNewTemplate.AddCard(lstxtTemplate.Text, 1, 17, mlngFormatID, lstxtTemplate.ID)
        RefreshTemplate lngID
    Else
        lstxtTemplate.Text = ""
    End If
End Sub


'卡片新增（凭证类型）
Private Sub lstxtType_Choose()
    mVoucherTypeID = lstxtType.TextMatrix(lstxtType.ReferRow, 1)
    RefreshTemplate lstxtTemplate.ID
End Sub
Private Sub lstxtType_AddNew()
    mVoucherTypeID = Card.AddCard(msgVoucherType)
    RefreshVoucherType mVoucherTypeID
End Sub
Private Sub lstxtType_Delete()
    If mVoucherTypeID > 0 Then
        If Card.DelCard(msgVoucherType, mVoucherTypeID) Then
            RefreshVoucherType
        End If
    End If
End Sub
Private Sub lstxtType_Edit()
    If mVoucherTypeID > 0 Then
        Card.EditCard msgVoucherType, mVoucherTypeID
        RefreshVoucherType mVoucherTypeID
    End If
End Sub
Private Sub lstxtType_ItemNotExist()
    Dim lngID As Long
    
    If frmMsgAdd.MsgAddShow("增加凭证类型", "凭证类型“" & Trim(lstxtType.Text) & "”不存在，是否新增?") = vbOK Then
        lngID = Card.AddCard(msgVoucherType, lstxtType.Text)
        RefreshVoucherType lngID
    Else
        lstxtType.Text = ""