test.cls

财务信息管理系统,适合做毕业论文的人使用

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "test"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit



'传入的数据
Private m_objXmlIn As New DOMDocument
'导入导出的模板
Private m_objImport As New DOMDocument
Private m_objExport As New DOMDocument
'提示信息返回
Private m_objRtn As New DOMDocument
'导出结果返回
Private m_objXmlOut As New DOMDocument
'保存连接
Private m_objCon As ADODB.Connection
'保存关键数据
Private m_sTranCode As String
Private m_sVchStyle As String

'设置连接
Private Function bCon(param As ADODB.Connection) As Boolean
    On Error GoTo last
    
    bCon = False
    '测试数据库是否正确
    param.Execute "select 1 from fd_transactions where 1>1"
    Set m_objCon = param
    m_objCon.CursorLocation = adUseClient
    bCon = True
    Exit Function
last:
    AppendRtn "-1", Error
End Function

'设置对应字段模板
'0设置输入
'1设置导入模板
'2设置导出模板

Private Function bSetTemplate(sParam As String, flag As Integer) As Boolean
    On Error GoTo last
    
    Dim node As IXMLDOMElement
    Dim doc As DOMDocument
    
    If flag = 0 Then
        Set doc = m_objXmlIn
    ElseIf flag = 1 Then
        Set doc = m_objImport
    Else
        Set doc = m_objExport
    End If
    
    bSetTemplate = False
    
    If sParam = "" Then
        AppendRtn "-1", "传入的参数不能为空!"
        Exit Function
    End If
    
    If flag = 0 Then
        If Not doc.loadXML(sParam) Then
            AppendRtn "-1", "输入的xml流不合法!", flag
            Exit Function
        End If
    Else
        If Not doc.Load(sParam) Then
            AppendRtn "-1", "指定的文件不存在!", flag
            Exit Function
        End If
    End If
    
    Set node = doc.documentElement.selectSingleNode("//" & sRootTag(doc))
    If node Is Nothing Then
        AppendRtn "-1", "xml格式不正确!", flag
        Exit Function
    End If

    bSetTemplate = True
    Exit Function
last:
    AppendRtn "-1", Error, flag
End Function

'获取输出
Private Property Get XmlOut() As String
    Dim node As IXMLDOMElement
    
    Set node = m_objRtn.documentElement.firstChild
    If node Is Nothing Then
        XmlOut = m_objXmlOut.xml
    Else
        XmlOut = m_objRtn.xml
    End If
End Property

'处理函数
Private Function bParse() As Boolean
    On Error GoTo last
    
    bParse = False
    '获取操作类型,都是相对于网上银行而言
    Select Case sType(m_objXmlIn)
    Case "export"   '导入银行数据
        ImportRecord
    Case "import"   '导出资金数据
        ExportRecord
    Case "list"     '返回类型的列表
        List
    Case "delete"  '删除
        Delete
    Case "mark"    '加成功标志
        Mark
    Case "demark"   '去掉成功标志
        DeMark
    Case Else
        AppendRtn "-1", "方法未定义!"
        Exit Function
    End Select
    bParse = True
    Exit Function
last:
    AppendRtn "-1", Error
End Function

'导入数据
Private Sub ImportRecord()
    Dim sql As String
    Dim Rs As New ADODB.Recordset
    Dim chk As ADODB.Recordset
    Dim con As ADODB.Connection
    Dim node As IXMLDOMNode
        
    '获取单据类型
    m_sVchStyle = sVchStyle(m_objXmlIn)
        
    If m_sVchStyle = "" Or Not IsNumeric(m_sVchStyle) Or IsNull(vInRecord(("select * from fd_entities where iBIType = '" & m_sVchStyle & "'"), m_objCon)) Then
        AppendRtn "-1", "错误的单据类型!"
        Exit Sub
    End If
    
    sql = "Select substring(fd_Transactions.transactions_id,1,2) as vchstyle,fd_Transactions.*,t1.cAccid as rcv_acc_code,t2.cAccid as pay_acc_code," & _
            "t3.cUnitCode as rcv_accunit_name,t4.cUnitCode as pay_accunit_name," & _
            "t1.cAccName as rcv_accdef_name,t2.cAccName as pay_accdef_name,fd_intra.cIntrID as irate_code," & _
            "fd_cadset.cCadID as cad_code from fd_Transactions " & _
            "left join fd_accdef as t1 on fd_Transactions.rcv_acc_id=t1.accdef_id " & _
            "left join fd_accdef as t2 on fd_Transactions.pay_acc_id=t2.accdef_id " & _
            "left join fd_accunit as t3 on t1.accunit_id=t3.accunit_id " & _
            "left join fd_accunit as t4 on t2.accunit_id=t4.accunit_id " & _
            "left join fd_intra on fd_Transactions.irate_id=fd_intra.irate_id " & _
            "left join fd_cadset on fd_Transactions.cad_id=fd_cadset.cad_id " & _
            "where 1>1"
            
    '设置校验字段
    Set chk = m_objCon.Execute(sql)
    
    '打开记录集
    sql = "select * from fd_transactions where 1>1"
    Rs.Open sql, m_objCon, adOpenDynamic, adLockOptimistic
    
    '导入获取的xml数据集
    For Each node In m_objXmlIn.documentElement.childNodes
        If node.nodeType = NODE_ELEMENT Then
            On Error Resume Next
            AppendRecord node, Rs, chk
        End If
    Next
End Sub

'导出数据
Private Sub ExportRecord(Optional rs1 As Object, Optional flag As Boolean = True, Optional ByRef con As ADODB.Connection)
    Dim sql As String
    Dim Rs As ADODB.Recordset
    
    On Error GoTo last
    '创建一下新的数据连接
    If con Is Nothing Then
        Set con = New ADODB.Connection
        con.CursorLocation = adUseClient
        con.ConnectionString = con
        con.Open
    End If
    con.BeginTrans
    '如果传入的是记录集
    If flag Then
        If Not rs1 Is Nothing Then
            Set Rs = rs1
        Else
            Set Rs = New ADODB.Recordset
        
            '获取数据,已经审核，未记账，未制单的记录导出
            sql = "Select substring(fd_Transactions.transactions_id,1,2) as vchstyle,fd_Transactions.*,t1.cAccid as rcv_acc_code,t2.cAccid as pay_acc_code," & _
                    "t3.cUnitCode as rcv_accunit_name,t4.cUnitCode as pay_accunit_name," & _
                    "t1.cAccName as rcv_accdef_name,t2.cAccName as pay_accdef_name,fd_intra.cIntrID as irate_code," & _
                    "fd_cadset.cCadID as cad_code from fd_Transactions " & _
                    "left join fd_accdef as t1 on fd_Transactions.rcv_acc_id=t1.accdef_id " & _
                    "left join fd_accdef as t2 on fd_Transactions.pay_acc_id=t2.accdef_id " & _
                    "left join fd_accunit as t3 on t1.accunit_id=t3.accunit_id " & _
                    "left join fd_accunit as t4 on t2.accunit_id=t4.accunit_id " & _
                    "left join fd_intra on fd_Transactions.irate_id=fd_intra.irate_id " & _
                    "left join fd_cadset on fd_Transactions.cad_id=fd_cadset.cad_id " & _
                    "where " & sCondition
            
            Rs.Open sql, m_objCon, adOpenDynamic, adLockOptimistic
            If Rs.RecordCount = 0 Then
                AppendRtn "-1", "查无结果,可能是业务类型错误!"
                Exit Sub
            End If
        End If
        '生成输出xml
        While Not Rs.EOF
           On Error Resume Next
           appendNode Rs, con
           Rs.MoveNext
        Wend
    '否则是xml文档
    Else
        Set m_objXmlOut = rs1
    End If
    
    '输出文档
    ExportDoc m_objXmlOut, con
    con.CommitTrans
    Exit Sub
last:
    con.RollbackTrans
    Err.Raise "1", "导出失败:" & Error
End Sub

'调用对方的导入功能
Private Sub ExportDoc(doc As DOMDocument, con As ADODB.Connection)
'    Dim root As IXMLDOMElement
'    Dim node As IXMLDOMNode
'    Dim succ As String
'
'    transaction.Transact doc.xml, m_objXmlIn.xml, con
'    Set root = m_objXmlIn.documentElement.selectSingleNode(sRootTag(m_objXmlIn))
'    succ = GetAttributeVal("succ", root.firstChild)
'    If succ = "-1" Then
'        Err.Raise 111, , "调用nb导入功能出错:" & GetAttributeVal("desc", node)
'        Exit Sub
'    End If
'
'    For Each node In root.childNodes
'        If node.nodeType = NODE_ELEMENT Then
'                con.Execute "update fd_transactions set importexport_flag='0' where transactions_id='" & GetAttributeVal("id", node) & "'"
'        End If
'    Next
End Sub

'获取单据类型列表
Private Sub List()
    Dim style As String
    Dim sql As String
    Dim Rs As ADODB.Recordset
    Dim root As IXMLDOMElement
    Dim node As IXMLDOMElement
    
    
    style = GetAttributeVal("type", m_objXmlIn.documentElement.selectSingleNode("//" & sRootTag(m_objXmlIn)))
    
    '返回支付单据类型
    If style = "pay" Or style = "all" Then
        sql = "select scaption,iid from fd_entities where iBIType=24 or ibitype=27 or ibitype=28"
        Set Rs = m_objCon.Execute(sql)
        If Rs.RecordCount = 0 Then
            AppendRtn "-1", "缺少支付单据类型定义!"
            Exit Sub
        End If
        While Not Rs.EOF
            AppendRtn "0", Rs!scaption, Rs!iID
            Rs.MoveNext
        Wend
    '返回收取单据类型
    ElseIf style = "rcv" Or style = "all" Then
        sql = "select scaption,iid from fd_entities where iBIType=25 or ibitype=26 or ibitype=28"
        Set Rs = m_objCon.Execute(sql)
        If Rs.RecordCount = 0 Then
            AppendRtn "-1", "缺少收付单据类型定义!"
            Exit Sub
        End If
        While Not Rs.EOF
            AppendRtn "0", Rs!scaption, Rs!iID
            Rs.MoveNext
        Wend
    End If
End Sub

'加成功标志
Private Sub Mark()
    Dim root As IXMLDOMElement
    Dim node As IXMLDOMElement
    Dim id As String
    Dim Rs As New ADODB.Recordset
    Dim sql As String
    
    Set root = m_objXmlIn.documentElement.selectSingleNode("//" & sRootTag(m_objXmlIn))
    For Each node In root.childNodes
        id = GetAttributeVal("id", node)
        If id = "" Then
            AppendRtn "1", "编号不能为空!"
        Else
            sql = "select success_flag from fd_transactions where invoice_code='" & id & "' and importexport_flag='1'"