transferpubic.bas

金算盘软件代码

    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 CustomerName(lngID As Long) As String
    Dim strSql As String
    Dim recCustomer As rdoResultset
    
    strSql = "SELECT * FROM Customer WHERE lngCustomerID=" & lngID
    Set recCustomer = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If Not recCustomer.EOF Then
        CustomerName = recCustomer!strCustomerCode & " " & recCustomer!strCustomerName
    Else
        CustomerName = ""
    End If
    recCustomer.Close
    Set recCustomer = Nothing
End Function

'取部门名称
Public Function DepartmentName(lngID As Long) As String
    Dim strSql As String
    Dim recDepartment As rdoResultset
    
    strSql = "SELECT * FROM Department WHERE lngDepartmentID=" & lngID
    Set recDepartment = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If Not recDepartment.EOF Then
        DepartmentName = recDepartment!strDepartmentCode & " " & recDepartment!strDepartmentName
    Else
        DepartmentName = ""
    End If
    recDepartment.Close
    Set recDepartment = Nothing
End Function

'取员工名称
Public Function EmployeeName(lngID As Long) As String
    Dim strSql As String
    Dim recEmployee As rdoResultset
    
    strSql = "SELECT * FROM Employee WHERE lngEmployeeID=" & lngID
    Set recEmployee = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If Not recEmployee.EOF Then
        EmployeeName = recEmployee!strEmployeeCode & " " & recEmployee!strEmployeeName
    Else
        EmployeeName = ""
    End If
    recEmployee.Close
    Set recEmployee = Nothing
End Function

'取工程名称
Public Function JobName(lngID As Long) As String
    Dim strSql As String
    Dim recJob As rdoResultset
    
    strSql = "SELECT * FROM Job WHERE lngJobID=" & lngID
    Set recJob = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If Not recJob.EOF Then
        JobName = recJob!strJobCode & " " & recJob!strJobName
    Else
        JobName = ""
    End If
    recJob.Close
    Set recJob = Nothing
End Function

'取统计名称
Public Function Class1Name(lngID As Long) As String
    Dim strSql As String
    Dim recClass As rdoResultset
    
    strSql = "SELECT * FROM Class1 WHERE lngClassID=" & lngID
    Set recClass = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    
    If Not recClass.EOF Then
        Class1Name = recClass!strClassCode & " " & recClass!strClassName
    Else
        Class1Name = ""
    End If
    recClass.Close
    Set recClass = Nothing
End Function

'取项目名称
Public Function Class2Name(lngID As Long) As String
    Dim strSql As String
    Dim recClass As rdoResultset
    
    strSql = "SELECT * FROM Class2 WHERE lngClassID=" & lngID
    Set recClass = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If Not recClass.EOF Then
        Class2Name = recClass!strClassCode & " " & recClass!strClassName
    Else
        Class2Name = ""
    End If
    recClass.Close
    Set recClass = Nothing
End Function

'取币种名称
Public Function CurrencyName(lngID As Long) As String
    Dim strSql As String
    Dim recCurrency As rdoResultset
    
    strSql = "SELECT * FROM Currencys WHERE lngCurrencyID=" & lngID
    Set recCurrency = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If Not recCurrency.EOF Then
        CurrencyName = recCurrency!strCurrencyCode & " " & recCurrency!strCurrencyName
    Else
        CurrencyName = ""
    End If
    recCurrency.Close
    Set recCurrency = Nothing
End Function

'操作员名称
Public Function OperatorName(lngOperatorID As Long) As String
    Dim strSql As String
    Dim recOperator As rdoResultset
    
    strSql = "SELECT * FROM Operator WHERE lngOperatorID=" & lngOperatorID
    Set recOperator = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If Not recOperator.EOF Then
        OperatorName = recOperator!strOperatorName
    End If
    recOperator.Close
    Set recOperator = Nothing
End Function

'取第一个单据模板
Public Function GettemplateID(ByVal lngReceiptTypeID As Long) As Long
    Dim errNo As Long
    Dim strSql As String
    Dim recTemplate As rdoResultset
    
    On Error GoTo ErrHandle
    
    strSql = "SELECT lngTemplateID FROM Template WHERE lngReceiptTypeID=" & lngReceiptTypeID
    Set recTemplate = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If Not recTemplate.EOF Then
        recTemplate.MoveFirst
        GettemplateID = recTemplate!lngTemplateID
    End If
    recTemplate.Close
    Set recTemplate = 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 recTemplate Is Nothing Then Set recTemplate = Nothing
End Function

'取凭证类别代码
Public Function GetVoucherTypeCode(ByVal lngVoucherTypeID As Long) As String
    Dim errNo As Long
    Dim strSql As String
    Dim recVoucherType As rdoResultset
    
    On Error GoTo ErrHandle
    
    strSql = "SELECT strVoucherTypeCode FROM VoucherType WHERE lngVoucherTypeID=" & lngVoucherTypeID
    Set recVoucherType = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If Not recVoucherType.EOF Then
        GetVoucherTypeCode = recVoucherType!strVoucherTypeCode
    End If
    recVoucherType.Close
    Set recVoucherType = 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 recVoucherType Is Nothing Then Set recVoucherType = Nothing
End Function

'取本位币种
Public Function GetCurrencyID() As Long
    Dim errNo As Long
    Dim strSql As String
    Dim recBusiness As rdoResultset
    
    On Error GoTo ErrHandle
    
    strSql = "SELECT  lngCurrencyID FROM Business"
    Set recBusiness = gclsBase.BaseDB.OpenResultset(strSql, dbOpenSnapshot)
    If Not recBusiness.EOF Then
        recBusiness.MoveFirst
        GetCurrencyID = recBusiness!lngCurrencyID
    End If
    recBusiness.Close
    Set recBusiness = 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 recBusiness Is Nothing Then Set recBusiness = Nothing
End Function

'取会计制度
Public Function GetAccountSystem() As String
    Dim errNo As Long
    Dim strSql As String
    Dim recBusiness As rdoResultset
    
    On Error GoTo ErrHandle
    
    strSql = "SELECT strAccountSystem FROM Business"
    Set recBusiness = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If Not recBusiness.EOF Then
        recBusiness.MoveFirst
        GetAccountSystem = recBusiness!strAccountSystem
    End If
    recBusiness.Close
    Set recBusiness = 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 recBusiness Is Nothing Then Set recBusiness = Nothing
End Function

'取帐套启用期间
Public Sub GetStartPeriod(intYear As Integer, intPeriod As Integer, Optional strDate As String)
    Dim errNo As Long
    Dim strSql As String
    Dim recBusiness As rdoResultset
    
    On Error GoTo ErrHandle
    
    strSql = "SELECT strStartDate FROM Business"
    Set recBusiness = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If Not recBusiness.EOF Then
        recBusiness.MoveFirst
        If IsDate(recBusiness!strStartDate) Then
            intPeriod = gclsBase.PeriodOfDate(CDate(recBusiness!strStartDate))
            intYear = gclsBase.FYearOfDate(CDate(recBusiness!strStartDate))
            strDate = recBusiness!strStartDate
        End If
    End If
    recBusiness.Close
    Set recBusiness = 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 recBusiness Is Nothing Then Set recBusiness = Nothing
End Sub

'检查科目期初是否平衡
Public Function CheckAccountBalance(Optional ByVal strDate As String) As Boolean
    Dim errNo As Long
    Dim strSql As String
    Dim recBalance As rdoResultset
    Dim dblAmount As Double
    Dim strTmp As String
    
    On Error GoTo ErrHandle
    
    If Not IsDate(strDate) Then strDate = Format(CDate(gclsBase.BeginDate) - 1, "yyyy-mm-dd")
    
    strSql = getQEndBalanceOraSql(strDate)
    Set recBalance = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    Do While Not recBalance.EOF
        Select Case recBalance!lngAccountTypeID
        Case 1
            dblAmount = dblAmount + recBalance!dblAmount
        Case 2
            dblAmount = dblAmount + recBalance!dblAmount
        Case 3
            dblAmount = dblAmount + recBalance!dblAmount
        Case 4
            dblAmount = dblAmount + recBalance!dblAmount
        Case 5
            dblAmount = dblAmount + recBalance!dblAmount
        Case Else
            dblAmount = dblAmount + recBalance!dblAmount
        End Select
        rec