transferpubic.bas

金算盘软件代码

    Dim lngCountSour As Long
    
    If UBound(VoucherData) >= lngSourCnt And UBound(VoucherData) >= lngDestCnt Then
        VoucherData(lngDestCnt).Used = VoucherData(lngSourCnt).Used
        VoucherData(lngDestCnt).VoucherID = VoucherData(lngSourCnt).VoucherID
        VoucherData(lngDestCnt).VoucherDate = VoucherData(lngSourCnt).VoucherDate
        VoucherData(lngDestCnt).TemplateID = VoucherData(lngSourCnt).TemplateID
        VoucherData(lngDestCnt).Number = VoucherData(lngSourCnt).Number
        VoucherData(lngDestCnt).VoucherTypeID = VoucherData(lngSourCnt).VoucherTypeID
        VoucherData(lngDestCnt).VoucherNO = VoucherData(lngSourCnt).VoucherNO
        VoucherData(lngDestCnt).OperatorID = VoucherData(lngSourCnt).OperatorID
        VoucherData(lngDestCnt).CheckerID = VoucherData(lngSourCnt).CheckerID
        VoucherData(lngDestCnt).PostID = VoucherData(lngSourCnt).PostID
        VoucherData(lngDestCnt).VoucherSourceID = VoucherData(lngSourCnt).VoucherSourceID
        VoucherData(lngDestCnt).SourceVoucherID = VoucherData(lngSourCnt).SourceVoucherID
        VoucherData(lngDestCnt).IsPrint = VoucherData(lngSourCnt).IsPrint
        VoucherData(lngDestCnt).IsVoid = VoucherData(lngSourCnt).IsVoid
        VoucherData(lngDestCnt).IsCancel = VoucherData(lngSourCnt).IsCancel
        VoucherData(lngDestCnt).IsError = VoucherData(lngSourCnt).IsError
        If VoucherData(lngSourCnt).Used Then
            lngCountSour = UBound(VoucherData(lngSourCnt).Detail)
            ReDim Preserve VoucherData(lngDestCnt).Detail(lngCountSour)
            For lngCnt = 0 To lngCountSour
                VoucherData(lngDestCnt).Detail(lngCnt).AccountID = VoucherData(lngSourCnt).Detail(lngCnt).AccountID
                VoucherData(lngDestCnt).Detail(lngCnt).Amount = VoucherData(lngSourCnt).Detail(lngCnt).Amount
                VoucherData(lngDestCnt).Detail(lngCnt).Attribute = VoucherData(lngSourCnt).Detail(lngCnt).Attribute
                VoucherData(lngDestCnt).Detail(lngCnt).ClassID1 = VoucherData(lngSourCnt).Detail(lngCnt).ClassID1
                VoucherData(lngDestCnt).Detail(lngCnt).ClassID2 = VoucherData(lngSourCnt).Detail(lngCnt).ClassID2
                VoucherData(lngDestCnt).Detail(lngCnt).CurrencyAmount = VoucherData(lngSourCnt).Detail(lngCnt).CurrencyAmount
                VoucherData(lngDestCnt).Detail(lngCnt).CurrencyID = VoucherData(lngSourCnt).Detail(lngCnt).CurrencyID
                VoucherData(lngDestCnt).Detail(lngCnt).CustomerID = VoucherData(lngSourCnt).Detail(lngCnt).CustomerID
                VoucherData(lngDestCnt).Detail(lngCnt).DepartmentID = VoucherData(lngSourCnt).Detail(lngCnt).DepartmentID
                VoucherData(lngDestCnt).Detail(lngCnt).DetailEntry = VoucherData(lngSourCnt).Detail(lngCnt).DetailEntry
                VoucherData(lngDestCnt).Detail(lngCnt).Direction = VoucherData(lngSourCnt).Detail(lngCnt).Direction
                VoucherData(lngDestCnt).Detail(lngCnt).EmployeeID = VoucherData(lngSourCnt).Detail(lngCnt).EmployeeID
'                VoucherData(lngDestCnt).Detail(lngCnt).JobID = VoucherData(lngSourCnt).Detail(lngCnt).JobID
                VoucherData(lngDestCnt).Detail(lngCnt).Price = VoucherData(lngSourCnt).Detail(lngCnt).Price
                VoucherData(lngDestCnt).Detail(lngCnt).Quantity = VoucherData(lngSourCnt).Detail(lngCnt).Quantity
                VoucherData(lngDestCnt).Detail(lngCnt).Rate = VoucherData(lngSourCnt).Detail(lngCnt).Rate
                VoucherData(lngDestCnt).Detail(lngCnt).Remark = VoucherData(lngSourCnt).Detail(lngCnt).Remark
            Next lngCnt
        End If
    End If
End Sub

'清除凭证模板数据
Public Sub InitVoucherRecord(VoucherData() As VoucherRecord)
    ReDim VoucherData(0)
    ReDim VoucherData(0).Detail(0)
    With VoucherData(0)
        .Used = False
        .Saved = False
        .VoucherID = 0
        .VoucherDate = ""
        .ErrorString = ""
        .TemplateID = 0
        .Number = 0
        .VoucherTypeID = 0
        .VoucherNO = 0
        .OperatorID = 0
        .CheckerID = 0
        .PostID = 0
        .VoucherSourceID = 0
        .SourceVoucherID = 0
        .IsPrint = False
        .IsVoid = False
        .IsCancel = False
        .IsError = False
        .Detail(0).Remark = " "
        .Detail(0).AccountID = 0
        .Detail(0).Direction = 0
        .Detail(0).Amount = 0
        .Detail(0).CurrencyID = 0
        .Detail(0).CurrencyAmount = 0
        .Detail(0).Rate = 0
        .Detail(0).Quantity = 0
        .Detail(0).Price = 0
        .Detail(0).ClassID1 = 0
        .Detail(0).ClassID2 = 0
        .Detail(0).JobID = 0
        .Detail(0).CustomerID = 0
        .Detail(0).DepartmentID = 0
        .Detail(0).EmployeeID = 0
    End With
End Sub

Public Sub InitVoucher(VoucherData As VoucherRecord)
    ReDim VoucherData.Detail(0)
    With VoucherData
        .Used = False
        .Saved = False
        .VoucherID = 0
        .VoucherDate = ""
        .ErrorString = ""
        .TemplateID = 0
        .Number = 0
        .VoucherTypeID = 0
        .VoucherNO = 0
        .OperatorID = 0
        .CheckerID = 0
        .PostID = 0
        .VoucherSourceID = 0
        .SourceVoucherID = 0
        .IsPrint = False
        .IsVoid = False
        .IsCancel = False
        .IsError = False
        .Detail(0).Remark = ""
        .Detail(0).AccountID = 0
        .Detail(0).Direction = 0
        .Detail(0).Amount = 0
        .Detail(0).CurrencyID = 0
        .Detail(0).CurrencyAmount = 0
        .Detail(0).Rate = 0
        .Detail(0).Quantity = 0
        .Detail(0).Price = 0
        .Detail(0).ClassID1 = 0
        .Detail(0).ClassID2 = 0
        .Detail(0).JobID = 0
        .Detail(0).CustomerID = 0
        .Detail(0).DepartmentID = 0
        .Detail(0).EmployeeID = 0
    End With
End Sub

'在结构数据中新增一张凭证
Public Sub NewVoucherPage(VoucherData() As VoucherRecord, intCntVoucher As Integer, intDetailNum As Integer)
    Dim lngCnt As Long
    
    intCntVoucher = UBound(VoucherData)
    If VoucherData(intCntVoucher).Used Then
        intCntVoucher = intCntVoucher + 1
        ReDim Preserve VoucherData(intCntVoucher)
        ReDim VoucherData(intCntVoucher).Detail(0)
    End If
    
    With VoucherData(intCntVoucher)
        .Used = False
        .VoucherID = 0
        .VoucherDate = ""
        .TemplateID = 0
        .Number = 0
        .VoucherTypeID = 0
        .VoucherNO = 0
        .OperatorID = 0
        .CheckerID = 0
        .PostID = 0
        .VoucherSourceID = 0
        .SourceVoucherID = 0
        .IsPrint = True
        .IsVoid = False
        .IsCancel = False
        .IsError = False
        For lngCnt = 0 To intDetailNum
            .Detail(lngCnt).Remark = ""
            .Detail(lngCnt).AccountID = 0
            .Detail(lngCnt).Direction = 0
            .Detail(lngCnt).Amount = 0
            .Detail(lngCnt).CurrencyID = 0
            .Detail(lngCnt).CurrencyAmount = 0
            .Detail(lngCnt).Rate = 0
            .Detail(lngCnt).Quantity = 0
            .Detail(lngCnt).Price = 0
            .Detail(lngCnt).ClassID1 = 0
            .Detail(lngCnt).ClassID2 = 0
            .Detail(lngCnt).JobID = 0
            .Detail(lngCnt).CustomerID = 0
            .Detail(lngCnt).DepartmentID = 0
            .Detail(lngCnt).EmployeeID = 0
        Next lngCnt
    End With
End Sub

'取科目所有属性
'入口：科目ID
'返回：科目性质（枚举型）
'      科目类型（枚举型）
'      科目属性（枚举型）
Public Function AccountAttribute(AccountID As Long, Optional AccountCode As String, _
    Optional AccountNature As enumAccountNature, Optional AccountType As enumAccountType) As enumAccountAttribute
    
    Dim errNo As Long
    Dim strSql As String
    Dim recTmp As rdoResultset
    
    On Error GoTo ErrHandle
    
    strSql = "SELECT * FROM Account WHERE lngAccountID=" & AccountID
    Set recTmp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If Not recTmp.EOF Then
        With recTmp
            AccountAttribute = AccountAttribute + IIf(!blnIsDetail = 1, aaDetail, 0)
            AccountAttribute = AccountAttribute + IIf(!blnIsInActive = 1, 0, aaActive)
            AccountAttribute = AccountAttribute + IIf(!intDirection = 1, aaDirection, 0)
            AccountAttribute = AccountAttribute + IIf(!blnIsCustomer = 1, aaCustomer, 0)
            AccountAttribute = AccountAttribute + IIf(!blnIsDepartment = 1, aaDepartment, 0)
            AccountAttribute = AccountAttribute + IIf(!blnIsEmployee = 1, aaEmployee, 0)
            AccountAttribute = AccountAttribute + IIf(!blnIsClass1 = 1, aaClass1, 0)
            AccountAttribute = AccountAttribute + IIf(!blnIsClass2 = 1, aaClass2, 0)
            AccountAttribute = AccountAttribute + IIf(!blnIsQuantity = 1, aaQuantity, 0)
            AccountAttribute = AccountAttribute + IIf(!blnIsMultCurrency = 1, aaMultCurrency, 0)
            AccountAttribute = AccountAttribute + IIf(!blnIsAllCurrency = 1, aaAllCurrency, 0)
            AccountCode = !strAccountCode
            AccountType = !lngAccountTypeID
            AccountNature = !lngAccountNatureID
            AccountID = !lngAccountID
        End With
    End If
    recTmp.Close
    Set recTmp = Nothing
    Exit Function
    
ErrHandle:
    errNo = Errors.ErrorsDeal()
    Select Case errNo
    Case edtResume: Resume
    Case edtResumeNext: Resume Next
    Case edtCanNotKnown
        ShowMsg 0, "程序出错：" & Err.Description, vbOKOnly + vbCritical, "打开科目表"
    End Select
    If Not recTmp Is Nothing Then Set recTmp = Nothing
End Function

'根据凭证ID设置凭证对方科目
Private Sub SetDebitCreditAccount(lngVoucherID As Long)
    Dim strDebitAccount As String
    Dim strCreditAccount As String
    Dim strSql As String
    Dim recVoucher As rdoResultset
    Dim recDetail As rdoResultset
    Dim errNo As Long
    
    On Error GoTo ErrHandle
    
    strSql = "SELECT * FROM Voucher WHERE lngVoucherID=" & lngVoucherID
    Set recVoucher = gclsBase.BaseDB.OpenResultset(strSql, rdOpenDynamic, rdConcurRowVer, 64)
    If Not recVoucher.EOF Then
        strSql = "SELECT * FROM VoucherDetail WHERE lngVoucherID=" & lngVoucherID
        Set recDetail = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
        Do While Not recDetail.EOF
            If recDetail!intDirection = adDebit Then
                strDebitAccount = strDebitAccount & AccountCode(recDetail!lngAccountID) & " "
            Else
                strCreditAccount = strCreditAccount & AccountCode(recDetail!lngAccountID) & " "
            End If
            recDetail.MoveNext
        Loop
        recDetail.Close
        Set recDetail = Nothing
        recVoucher.Edit
        recVoucher!strDebitAccountCode = strDebitAccount
        recVoucher!strCreditAccountCode = strCreditAccount
        recVoucher.Update
    End If
    recVoucher.Close
    Set recVoucher = Nothing
    Exit Sub
    
ErrHandle:
    errNo = Errors.ErrorsDeal()
    Select Case errNo
    Case edtResume: Resume
    Case edtResumeNext: Resume Next
    Case edtCanNotKnown
        ShowMsg 0, "程序出错：" & Err.Description, vbOKOnly + vbCritical, "打开凭证库"
    End Select
    If Not recDetail Is Nothing Then Set recDetail = Nothing
    If Not recVoucher Is Nothing Then Set recVoucher = Nothing
End Sub

'取科目代码
Public Function AccountCode(lngAccountID As Long, Optional blnName As Boolean) As String

    Dim errNo As Long
    Dim strSql As String
    Dim recTmp As rdoResultset
    
    On Error GoTo ErrHandle
    
    strSql = "SELECT strAccountCode,strAccountName FROM Account WHERE lngAccountID=" & lngAccountID
    Set recTmp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If Not recTmp.EOF Then
        AccountCode = Trim$(recTmp!strAccountCode)
        If blnName Then
            AccountCode = AccountCode & " " & Trim$(recTmp!strAccountName)
        End If
    End If
    recTmp.Close
    Set recTmp = Nothing
    Exit Function
    
ErrHandle:
    errNo = Errors.ErrorsDeal()
    Select Case errNo
    Case edtResume: Resume
    Case edtResumeNext: Resume Next
    Case edtCanNotKnown
        ShowMsg 0, "程序出错：" & Err.Description, vbOKOnly + vbCritical, "打开科目表"
    End Select
    If Not recTmp Is Nothing Then Set recTmp = Nothing
End Function

'取科目代码
Public Function AccountCodeID(strCode As String) As Long

    Dim errNo As Long
    Dim strSql As String
    Dim recTmp As rdoResultset
    
    On Error GoTo ErrHandle
    
    strSql = "SELECT * FROM Account WHERE strAccountCode='" & strCode & "'"
    Set recTmp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If Not recTmp.EOF Then
        AccountCodeID = Trim$(recTmp!lngAccountID)
    End If
    recTmp.Close
    Set recTmp = Nothing