frmfixedvoucher.frm

金算盘软件代码

                End If
'                recNow.MoveNext
'            Loop
'            '根据上次变动搜索本次变动
'            If Not recLast.EOF Then
'                recLast.MoveLast
'                recLast.MoveFirst
'            End If
'            Do While Not recLast.EOF
'                recLast.FindFirst "lngCurrencyID=" & recLast!lngCurrencyID
'                If recLast.NoMatch Then
'                    dblValue = -recLast!dblAmount
'                    dblCurrValue = -recLast!dblCurrAmount
'                    dblAccountValue = dblAccountValue + dblValue
'                    lngCurrencyID = recLast!lngCurrencyID
'                    Call FixedAccountVoucher(strRemark, strAccountCode, strAccount, dblValue, _
'                        dblCurrValue, lngAccountID, lngVoucherTypeID, lngTemplateID, lngFixedAlterID _
'                        , lngCurrencyID)
'                End If
'                recLast.MoveNext
'            Loop
            '查找科目
            strSql = "SELECT strAccountCode,strAccountName,blnIsInActive FROM " _
                & "Account WHERE lngAccountID=" & lngAccountID
            Set recs1 = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
            If recs1.EOF() Then
                ShowMsg Me.hwnd, "固资编码为：" & Trim(msgVoucher.TextMatrix(i, 11)) _
                    & "的变动记录所指定的变动方式的变动科目不存在" _
                    & "，请修改后继续生成固定资产凭证", vbExclamation, Me.Caption
                stbVoucher.Tab = 0
                mblnVoucherOK = False
                Exit Sub
            ElseIf recs1!blnIsInActive = 1 Then
                ShowMsg Me.hwnd, "固资编码为：" & Trim(msgVoucher.TextMatrix(i, 11)) _
                    & "的变动记录所指定的变动方式的变动科目已停用" _
                    & "，请修改后继续生成固定资产凭证", vbExclamation, Me.Caption
                stbVoucher.Tab = 0
                mblnVoucherOK = False
                Exit Sub
            Else
                strAccount = Trim(recs1!strAccountCode & " " & recs1!strAccountName)
                strAccountCode = recs1!strAccountCode
            End If
            '查找凭证类别
            strSql = "SELECT lngVoucherTypeID,blnIsInActive FROM VoucherType WHERE lngVoucherTypeID=" & lngVoucherTypeID
            Set recs1 = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
            If recs1.EOF() Then
                ShowMsg Me.hwnd, "固资编码为：" & Trim(msgVoucher.TextMatrix(i, 11)) _
                    & "的变动记录所指定的变动方式的凭证类别不存在" _
                    & "，请修改后继续生成固定资产凭证", vbExclamation, Me.Caption
                stbVoucher.Tab = 0
                mblnVoucherOK = False
                Exit Sub
            ElseIf recs1!blnIsInActive = 1 Then
                ShowMsg Me.hwnd, "固资编码为：" & Trim(msgVoucher.TextMatrix(i, 11)) _
                    & "的变动记录所指定的变动方式的凭证类别已停用" _
                    & "，请修改后继续生成固定资产凭证", vbExclamation, Me.Caption
                stbVoucher.Tab = 0
                mblnVoucherOK = False
                Exit Sub
            End If
            recs1.Close
            Set recs1 = Nothing
            With msgVoucherGrid
                If dblValue > 0 Then
                    strFixeddirection = "    贷："
                ElseIf dblValue < 0 Then
                    strFixeddirection = "借："
                ElseIf dblAlterDeprection < 0 Then
                    strFixeddirection = "    贷："
                Else
                    strFixeddirection = "借："
                End If
                If .Rows > 1 Then
'                    If optVoucher(0).Value Then
'                        If .TextMatrix(.Rows - 1, 1) <> "" Then
'                            .AddItem ""
'                        End If
'                        lngRow = .Rows - 1
'                    Else
                        For lngRow = .Rows - 1 To 0 Step -1
                            If .TextMatrix(lngRow, 1) = "" Then
                                lngRow = IIf(lngRow = .Rows - 1, lngRow, -1)
                                Exit For
                            End If
                            If lngAccountID = C2lng(.TextMatrix(lngRow, 3)) And IIf(strFixeddirection = "借：", .TextMatrix(lngRow, 6) = "1", .TextMatrix(lngRow, 6) = "-11") Then
                                Exit For
                            End If
                        Next lngRow
                        If lngRow < 0 Then
                            .AddItem ""
                            lngRow = .Rows - 1
                        End If
'                    End If
                Else
                    If .TextMatrix(0, 1) <> "" Then .AddItem ""
                    lngRow = .Rows - 1
                End If
                If .TextMatrix(lngRow, 1) = "" Then
                    .TextMatrix(lngRow, 0) = strRemark
                    .TextMatrix(lngRow, 1) = strFixeddirection & strAccount
                    
                    .TextMatrix(lngRow, 2) = Format(Abs(dblValue - dblAlterDeprection), "###,###,###.00")
                    .TextMatrix(lngRow, 3) = lngAccountID
                    .TextMatrix(lngRow, 4) = lngVoucherTypeID
                    .TextMatrix(lngRow, 5) = lngTemplateID
                    .TextMatrix(lngRow, 7) = strAccountCode
                    .TextMatrix(lngRow, 8) = lngFixedAlterID
                    .TextMatrix(lngRow, 14) = Format(Abs(dblValue - dblAlterDeprection), "###,###,###.00")
                    .TextMatrix(lngRow, 15) = gclsBase.NaturalCurId
                    If strFixeddirection = "借：" Then
                        .TextMatrix(lngRow, 6) = 1
                    Else
                        .TextMatrix(lngRow, 6) = -1
                    End If
                Else
                    .TextMatrix(lngRow, 2) = Format(Abs(C2Dbl(.TextMatrix(lngRow, 2)) + Abs(dblValue - dblAlterDeprection)), "###,###,###.00")
                    .TextMatrix(lngRow, 14) = C2Dbl(.TextMatrix(lngRow, 14)) + Abs(dblValue - dblAlterDeprection)
                End If
                '折旧变动录入
                If dblAlterDeprection <> 0 Then
                    Call FixedOldPart(lngFixedAlterID, lngVoucherTypeID, lngTemplateID, dblAlterDeprection)
                End If
                If InStr(.TextMatrix(lngRow, 1), "借") > 0 Then
                    Change_Row msgVoucherGrid, lngRow, 0
                End If
                If dblAlterDeprection <> 0 Then
                    If lngRow + 1 < .Rows Then
                        If InStr(.TextMatrix(lngRow + 1, 1), "借") > 0 Then
                            Change_Row msgVoucherGrid, lngRow + 1, 0
                        End If
                    End If
                End If
            End With
        End If
    End With
End Sub
'写凭证库
Private Function WriteVoucher(ByRef j As Integer) As Boolean
    Dim intVoucherNO As Integer
    Dim strVoucherNo As String
    Dim intYear As Integer
    Dim bytPeriod As Byte
    Dim strDate As String
    Dim lngOperatorID As Long
    Dim strDebitAccountCode As String
    Dim strSql As String
    Dim recVoucher As rdoResultset
    Dim i As Integer
    Dim strID As String
    Dim lngVoucherTypeID As Long
    Dim lngTemplateID As Long
    Dim strCreditAccountCode As String
    Dim lngAccountID As Long
    Dim lngVoucherID As Long
    Dim lngVoucherDetailID As Long
    Dim lngFixedAlterID As Long
    Dim lngRowID As Long
    Dim strDebit As String
    Dim strCredit As String
    On Error GoTo Errors1
    WriteVoucher = True
    intYear = gclsBase.AccountYear
    bytPeriod = gclsBase.Period
    strDate = Format(gclsBase.BaseDate, "yyyy-mm-dd")
    lngOperatorID = gclsBase.OperatorID
    With msgVoucherGrid
        lngVoucherTypeID = .TextMatrix(j, 4)
        '申请凭证号
        strVoucherNo = TransferPublic.GetMaxNO(intYear, bytPeriod, 41, lngVoucherTypeID, gclsBase.BaseDate)
        intVoucherNO = CInt(Right(strVoucherNo, 4))
        If intVoucherNO = 0 Then
            If gclsBase.NoOrder = True Then
                ShowMsg hwnd, "自动生成的凭证编号不满足序时控制", vbExclamation, Caption
            Else
                ShowMsg hwnd, "凭证编号生成失败！", vbExclamation, Caption
            End If
            WriteVoucher = False
            Exit Function
        End If
        lngTemplateID = .TextMatrix(j, 5)
        lngFixedAlterID = .TextMatrix(j, 8)
        strDebitAccountCode = ""
        strCreditAccountCode = ""
        i = j
        Do While i < .Rows
            If Len(Trim(.TextMatrix(i, 1))) > 0 Then
                If .TextMatrix(i, 6) = 1 Then   '借方
                    strDebitAccountCode = strDebitAccountCode & " " & .TextMatrix(i, 7)
                Else
                    strCreditAccountCode = strCreditAccountCode & " " & .TextMatrix(i, 7)
                End If
            Else
                Exit Do
            End If
            i = i + 1
        Loop
    End With
    '写凭证头
    lngVoucherID = GetNewID("Voucher")
    strSql = "INSERT INTO Voucher (lngVoucherID , lngVoucherTypeID,intVoucherNO" _
        & ",intYear,bytPeriod,strDate,lngTemplateID,lngOperatorID," _
        & "strDebitAccountCode,strCreditAccountCode,lngVoucherSourceID" _
        & ") VALUES(" & lngVoucherID & "," & lngVoucherTypeID & "," & intVoucherNO & "," _
        & intYear & "," & bytPeriod & ",'" & strDate & "'," & lngTemplateID _
        & "," & lngOperatorID & ",'" _
        & strDebitAccountCode & "','" & strCreditAccountCode & "',14)"
    If gclsBase.ExecSQL(strSql) Then
        strSql = "SELECT lngVoucherID FROM Voucher WHERE lngVoucherTypeID=" _
            & lngVoucherTypeID & " AND " & "intVoucherNO=" & intVoucherNO
        Set recVoucher = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
        recVoucher.MoveLast
        lngVoucherID = recVoucher!lngVoucherID
        If mVoucherID(UBound(mVoucherID)) > 0 Then
            ReDim Preserve mVoucherID(UBound(mVoucherID) + 1)
        End If
        mVoucherID(UBound(mVoucherID)) = lngVoucherID
        mlngVoucherID = lngVoucherID
        recVoucher.Close
        Set recVoucher = Nothing
        '写明细凭证
        i = j
        With msgVoucherGrid
            If mlngFirstType = 2 Then
                strDebit = "-1"
                strCredit = "1"
            Else
                strDebit = "1"
                strCredit = "-1"
            End If
            '写借方凭证
            lngRowID = 0
            Do While i < .Rows
                If Len(Trim(.TextMatrix(i, 1))) > 0 Then
                    If Trim(.TextMatrix(i, 6)) = strDebit Then
                        lngVoucherDetailID = GetNewID("VoucherDetail")
                        strSql = "INSERT INTO VoucherDetail (lngVoucherDetailID,lngVoucherID,strRemark,lngAccountID," _
                            & "intDirection,dblAmount,lngCurrencyID,dblRate,dblCurrencyAmount,lngRowID) VALUES(" & lngVoucherDetailID & "," & lngVoucherID & ",'" _
                            & .TextMatrix(i, 0) & " '," & .TextMatrix(i, 3) & "," & .TextMatrix(i, 6) _
                            & "," & Format(.TextMatrix(i, 2), "#########.00") & "," & gclsBase.NaturalCurId & ",1," _
                            & C2Dbl(.TextMatrix(i, 14)) & "," & lngRowID & ")"
                        gclsBase.BaseDB.Execute strSql
                    End If
                Else
                    Exit Do
                End If
                i = i + 1
                lngRowID = lngRowID + 1
            Loop
            i = j
            '写贷方凭证
            Do While i < .Rows
                If Len(Trim(.TextMatrix(i, 1))) > 0 Then
                    If Trim(.TextMatrix(i, 6)) = strCredit Then
                        lngVoucherDetailID = GetNewID("VoucherDetail")
                        strSql = "INSERT INTO VoucherDetail (lngVoucherDetailID , lngVoucherID,strRemark,lngAccountID," _
                            & "intDirection,dblAmount,lngCurrencyID,dblRate,dblCurrencyAmount,lngRowID) VALUES(" & lngVoucherDetailID & " , " & lngVoucherID & ",'" _
                            & .TextMatrix(i, 0) & " '," & .TextMatrix(i, 3) & "," & .TextMatrix(i, 6) _
                            & "," & Format(.TextMatrix(i, 2), "#########.00") & "," & gclsBase.NaturalCurId & ",1," _
                            & C2Dbl(.TextMatrix(i, 14)) & "," & lngRowID & ")"
                        gclsBase.BaseDB.Execute strSql
                    End If
                Else
                    Exit Do
                End If
                i = i + 1
                lngRowID = lngRowID + 1
            Loop
        End With
        '凭证ID
        j = i
        strID = ""
    '    If optVoucher(0).Value Then
    '        strSql = "UPDATE FixedAlter SET lngVoucherID=" & lngVoucherID _
    '            & " WHERE lngFixedAlterID=" & lngFixedAlterID
    '    Else
            With msgVoucher
                For i = 1 To .Rows - 1
                    If .TextMatrix(i, 10) = "√" Then    '.TextMatrix(i, 7) = lngFixedAlterID And
                        If strID = "" Then
                            strID = .TextMatrix(i, 0)
                        Else
                            strID = strID & "," & .TextMatrix(i, 0)
                        End If
                    End If
                Next i
                If strID <> "" Then
                    strID = "(" & strID & ")"
                    strSql = "UPDATE FixedAlter SET lngVoucherID=" & lngVoucherID _
                        & " WHERE lngFixedAlterID IN " & strID
                End If
            End With
    '    End If
        If strSql <> "" Then
            gclsBase.BaseDB.Execute strSql
        End If
        WriteVoucher = True        'mdlAccount.ChangeAllAccount_from_Voucher("I", lngVoucherID)
        '写余额库
        If Not mdlAccount.ChangeAllAccount_from_Voucher("I", lngVoucherID) Then GoTo Errors1
    Else
        WriteVoucher = False
    End If
    Exit Function
Errors1:
    WriteVoucher = False
    '归还凭证号
    Call BillPublic.blnMaxNODecrease(intYear, bytPeriod, 41, lngVoucherTypeID, intVoucherNO)
End Function
'折旧费用分摊(折旧变动）
Private Sub FixedOldPart(ByVal lngFixedAlterID As Long, ByVal lngVoucherTypeID As Long, _
    ByVal lngTemplateID As Long, ByVal dblAmount As Double)
    Dim recOldAccount As rdoResultset