frmfixedvoucher.frm

金算盘软件代码

    Dim qrfFixedOldPart As New rdoQuery
    Dim strSql As String
    Dim lngRow As Integer
    Dim dblValue As Double
    Dim dblSumValue As Double
    Dim recResultset As rdoResultset
    Dim lngAccountID As Long
    Dim strAccountCode As String
    Dim strAccountName As String
    '查找累计折旧科目
    strSql = "SELECT strSetting FROM Setting WHERE lngModuleID=10 AND " _
        & "RTrim(LTrim(strKey))='累计折旧'"
    Set recResultset = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If recResultset.EOF Then
        stbVoucher.Tab = 0
        ShowMsg Me.hwnd, "请选择固定资产累计折旧科目", vbExclamation, Me.Caption
        mblnVoucherOK = False
        Exit Sub
'    ElseIf recResultset!blnIsDepartment Or recResultset!blnIsCustomer Or recResultset!blnIsEmployee Or recResultset!blnIsClass1 Or recResultset!blnIsClass2 Then
'        stbVoucher.Tab = 0
'        ShowMsg Me.hwnd, "固定资产累计折旧科目不能有辅助核算属性", vbExclamation, Me.Caption
'        mblnVoucherOK = False
'        Exit Sub
    Else
        lngAccountID = recResultset!strSetting
    End If
    strSql = "SELECT strAccountCode,strAccountName FROM Account WHERE lngAccountID=" & lngAccountID
    Set recResultset = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    strAccountCode = Trim(recResultset!strAccountCode)
    strAccountName = Trim(recResultset!strAccountName)
    recResultset.Close
    Set recResultset = Nothing
    '折旧分摊
'    strSql = "SELECT FixedAccount.lngAccountID,Sum(FixedAccount.dblRate*" _
'        & "FixedBalance.dblAlterDeprection/100) AS 借方金额" _
'        & " FROM ((FixedCard LEFT JOIN FixedAlter ON FixedCard.lngFixedCardID=" _
'        & "FixedAlter.lngFixedCardID AND FixedCard.lngRecentFixedAlterID=" _
'        & "FixedAlter.lngFixedAlterID) LEFT JOIN FixedAccount ON " _
'        & "FixedAccount.lngFixedAlterID=FixedAlter.lngFixedAlterID) LEFT JOIN " _
'        & "FixedBalance ON FixedBalance.lngFixedCardID=FixedCard.lngFixedCardID " _
'        & "WHERE FixedAlter.blnIsVoid=FALSE AND FixedAlter.lngFixedAlterID=" _
'        & lngFixedAlterID & " GROUP BY lngAccountID"
'    On Error GoTo Errors1
'    Set qrfFixedOldPart = gclsBase.BaseDB.CreateQueryDef("FixedOldPart", strSql)
'    strSql = "SELECT Account.lngAccountID AS ID,Account.strAccountCode AS Code, " _
'        & "FixedAccount.lngClassID1,FixedAccount.lngClassID2" _
'        & ",FixedAccount.lngCustomerID,FixedAccount.lngDepartMentID,FixedAccount.lngEmployeeID" _
'        & ", Account.strAccountCode+' '+Account.strAccountName AS strAccountName," _
'        & "FixedOldPart.借方金额 AS dblValue FROM (FixedAccount INNER JOIN Account" _
'        & " ON FixedAccount.lngAccountID=Account.lngAccountID) INNER JOIN " _
'        & "FixedOldPart ON Account.lngAccountID=FixedOldPart.lngAccountID"
'    Set recOldAccount = gclsBase.BaseDB.OpenResultset(Strsql, rdOpenstatic)
'    With msgVoucherGrid
''        dblSumValue = 0
''        If Not recOldAccount.EOF Then
''            recOldAccount.MoveLast
''            recOldAccount.MoveFirst
''        End If
''        Do While Not recOldAccount.EOF
'            .AddItem ("")
'            i = .Rows - 1
'            .TextMatrix(i, 0) = " "
'            dblSumValue = recOldAccount!dblValue + dblSumValue
'            If recOldAccount!dblValue > 0 Then
'                .TextMatrix(i, 1) = "借：" & recOldAccount!strAccountName
'                .TextMatrix(i, 6) = 1
'            Else
'                .TextMatrix(i, 1) = "贷：" & recOldAccount!strAccountName
'                .TextMatrix(i, 6) = -1
'            End If
'            If Me.TextWidth(.TextMatrix(i, 1)) + 200 > .ColWidth(1) Then
'                .ColWidth(1) = Me.TextWidth(.TextMatrix(i, 1)) + 200
'            End If
'            .TextMatrix(i, 0) = "调整折旧"
'            .TextMatrix(i, 2) = Format(Abs(recOldAccount!dblValue), "###,###,###.00")
'            .TextMatrix(i, 3) = recOldAccount!ID
'            .TextMatrix(i, 4) = lngVoucherTypeID
'            .TextMatrix(i, 5) = lngTemplateID
'            .TextMatrix(i, 7) = recOldAccount!Code
'            .TextMatrix(i, 8) = lngFixedAlterID
'            .TextMatrix(i, 10) = recOldAccount!lngClassID1
'            .TextMatrix(i, 11) = recOldAccount!lngClassID2
'            .TextMatrix(i, 12) = recOldAccount!lngCustomerID
'            .TextMatrix(i, 13) = recOldAccount!lngDepartmentID
'            .TextMatrix(i, 14) = recOldAccount!lngEmployeeID
'            recOldAccount.MoveNext
'        Loop
        '增加固定资产对应科目的分录
        With msgVoucherGrid
        If .Rows > 0 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 = .TextMatrix(lngRow, 3) And IIf(dblAmount > 0, .TextMatrix(lngRow, 6) = "-1", .TextMatrix(lngRow, 6) = "1") 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
        dblSumValue = dblAmount
        If .TextMatrix(lngRow, 1) = "" Then
            '如果当前行的上一行为空，则摘要为调整累计折旧，否则为上一行的摘要
            If lngRow > 0 Then
                If .TextMatrix(lngRow - 1, 1) = "" And .TextMatrix(lngRow - 1, 2) = "" Then
                    .TextMatrix(lngRow, 0) = "调整折旧"
                Else
                    .TextMatrix(lngRow, 0) = .TextMatrix(lngRow - 1, 0)
                End If
            Else
                .TextMatrix(lngRow, 0) = "调整折旧"
            End If
            If dblSumValue > 0 Then
                .TextMatrix(lngRow, 1) = "    贷：" & strAccountCode & " " & strAccountName
                .TextMatrix(lngRow, 6) = -1
            Else
                .TextMatrix(lngRow, 1) = "借：" & strAccountCode & " " & strAccountName
                .TextMatrix(lngRow, 6) = 1
            End If
            .TextMatrix(lngRow, 2) = Format(Abs(dblSumValue), "###,###,###.00")
            .TextMatrix(lngRow, 3) = lngAccountID
            .TextMatrix(lngRow, 4) = lngVoucherTypeID
            .TextMatrix(lngRow, 5) = lngTemplateID
            .TextMatrix(lngRow, 7) = strAccountCode
            .TextMatrix(lngRow, 8) = lngFixedAlterID
            .TextMatrix(lngRow, 9) = 0
            .TextMatrix(lngRow, 10) = 0
            .TextMatrix(lngRow, 11) = 0
            .TextMatrix(lngRow, 12) = 0
            .TextMatrix(lngRow, 13) = 0
            .TextMatrix(lngRow, 14) = Format(Abs(dblSumValue), "###,###,###.00")
            .TextMatrix(lngRow, 15) = gclsBase.NaturalCurId
        Else
            .TextMatrix(lngRow, 2) = Format(Abs(CDbl(.TextMatrix(lngRow, 2)) + Abs(dblSumValue)), "###,###,###.00")
            .TextMatrix(lngRow, 14) = Format(C2Dbl(.TextMatrix(lngRow, 14)) + Abs(dblSumValue), "###,###,###.00")
        End If
    End With
'    recOldAccount.Close
    Set recOldAccount = Nothing
    Exit Sub
Errors1:
'    gclsBase.BaseDB.QueryDefs.Delete "FixedOldPart"
'    Set qrfFixedOldPart = gclsBase.BaseDB.CreateQueryDef("FixedOldPart", strSQL)
    Resume Next
End Sub
'检查凭证类型的科目
Private Function CheckVoucherAccount() As Boolean
    Dim lngDebitAccountID() As Long               '借方科目
    Dim lngCreditAccountID() As Long              '贷方科目
    Dim i As Long
    Dim j As Long
    Dim lngDeNumber As Long                       '借方科目数量
    Dim lngCrNumber As Long                       '贷方科目数量
    Dim lngVoucherTypeID As Long                  '凭证类型ID
    Dim strErr As String
    Dim strSql As String
'    Dim recType As Recordset
    Dim recType As rdoResultset
    '取科目ID数组
    lngDeNumber = 0
    lngCrNumber = 0
    CheckVoucherAccount = False
    With msgVoucherGrid
        lngVoucherTypeID = C2lng(.TextMatrix(0, 4))
        i = 0
        Do While i < .Rows
            '借方科目
            If Trim(.TextMatrix(i, 1)) <> "" Then
                If .TextMatrix(i, 6) = 1 Then
                    lngDeNumber = lngDeNumber + 1
                    ReDim lngDebitAccountID(lngDeNumber)
                    lngDebitAccountID(lngDeNumber - 1) = CLng(.TextMatrix(i, 3))
                    '另外一类凭证
                    If lngVoucherTypeID <> Val(.TextMatrix(i, 4)) And Trim(.TextMatrix(i, 4)) <> "" Then
                        If Not Salary.ValidVoucherAccount(lngVoucherTypeID, lngDebitAccountID(), lngCreditAccountID(), strErr) Then
                            ShowMsg Me.hwnd, strErr, vbExclamation, Me.Caption
                            Exit Function
                        Else
                            strErr = ""
                            strSql = "SELECT * FROM VoucherType WHERE lngVoucherTypeID=" & lngVoucherTypeID
                            Set recType = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
                            If Not recType.EOF Then
                                Select Case recType!strVoucherFormat
                                Case "0"  '记帐凭证
                                Case "1"  '收款凭证
                                    If lngDeNumber <> 1 Then
                                        strErr = "收款格式的凭证必须只有一个借方科目！"
                                    Else
                                        mlngFirstType = 1
                                        For j = i - 1 To 1 Step -1
                                            If lngVoucherTypeID = Val(.TextMatrix(j, 4)) Then
                                                .TextMatrix(j, 16) = 1
                                            Else
                                                Exit For
                                            End If
                                        Next j
                                    End If
                                Case "2"  '付款凭证
                                    If lngCrNumber <> 1 Then
                                        strErr = "付款格式的凭证必须只有一个贷方科目！"
                                    Else
                                        mlngFirstType = 2
                                        For j = i - 1 To 1 Step -1
                                            If lngVoucherTypeID = Val(.TextMatrix(j, 4)) Then
                                                .TextMatrix(j, 16) = -1
                                            Else
                                                Exit For
                                            End If
                                        Next j
                                    End If
                                End Select
                            Else
                                strErr = "凭证类别已被删除，不能生成凭证！"
                            End If
                            recType.Close
                            Set recType = Nothing
                            If strErr <> "" Then
                                ShowMsg Me.hwnd, strErr, vbExclamation, Me.Caption
                                Exit Function
                            End If
                        End If
                        lngVoucherTypeID = .TextMatrix(i, 4)
                        lngDeNumber = 0
                        lngCrNumber = 0
                    End If
                Else
                    lngCrNumber = lngCrNumber + 1
                    ReDim lngCreditAccountID(lngCrNumber)
                    lngCreditAccountID(lngCrNumber - 1) = CLng(.TextMatrix(i, 3))
                    '另外一类凭证
                    If lngVoucherTypeID <> .TextMatrix(i, 4) Then
                        If Not Salary.ValidVoucherAccount(lngVoucherTypeID, lngDebitAccountID(), lngCreditAccountID(), strErr) Then
                            ShowMsg Me.hwnd, strErr, vbExclamation, Me.Caption
                            Exit Function
                        Else
                            strSql = "SELECT * FROM VoucherType WHERE lngVoucherTypeID=" & lngVoucherTypeID
                            Set recType = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
                            If Not recType.EOF Then
                                Select Case recType!strVoucherFormat
                                Case "0"  '记帐凭证
                                Case "1"  '收款凭证
                                    If lngDeNumber <> 1 Then
                                        strErr = "收款格式的凭证必须只有一个借方科目！"
                                    Else
                                        mlngFirstType = 1
                                        For j = i - 1 To 1 Step -1
                                            If lngVoucherTypeID = Val(.TextMatrix(j, 4)) Then
                                                .TextMatrix(j, 16) = 1
                                            Else
                                                Exit For
                                            End If
                                        Next j
                                    End If
                                Case "2"  '付款凭证
                                    If lngCrNumber <> 1 Then
                                        strErr = "付款格式的凭证必须只有一个贷方科目！"
                                    Else
                                        mlngFirstType = 2
                                        For j = i - 1 To 1 Step -1
                                            If lngVoucherTypeID = Val(.TextMatrix(j, 4)) Then
                                                .TextMatrix(j, 16) = -1
                                            Else
                                                Exit For
                                            End If
                                        Next j
                                    End If
                                End Select
                            Else
                                strErr = "凭证类别已被删除，不能生成凭证！"
                            End If
                            recType.Close
                            Set recType = Nothing
                            If strErr <> "" Then
                                ShowMsg Me.hwnd, strErr, vbExclamation, Me.Caption
                                Exit Function
                            End If
                        End If
                        lngVoucherTypeID = .TextMatrix(i, 4)
                        lngCrNumber = 0
                        lngDeNumber = 0
                    End If
                End If
            End If
            i = i + 1
        Loop
        If lngVoucherTypeID > 0 Then
            strSql = "SELECT * FROM VoucherType WHERE lngVoucherTypeID=" & lngVoucherTypeID
            Set recType = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
            If Not recType.EOF Then
                Select Case recType!strVoucherFormat
                Case "0"  '记帐凭证
                Case "1"  '收款凭证
                    If lngDeNumber <> 1 Then
                        strErr = "收款格式的凭证必须只有一个借方科目！"
                    Else