test.cls

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

            Rs.Open sql, m_objCon, adOpenDynamic, adLockOptimistic
            If Rs.RecordCount = 0 Then
                AppendRtn "1", "错误的单据号!", id
            ElseIf CInt(Rs!success_flag) = 0 Then
                Rs!success_flag = 1
                Rs.Update
                'AppendRtn "0", "添加成功标志成功!", id
            Else
                'AppendRtn "0", "已添加过成功标志!", id
            End If
            Rs.Close
        End If
    Next
End Sub

'去掉查询条件
Private Sub DeMark()
'必须是未记账,未制单的记录才能进行
    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 pz_code is null and book_name is null and importexport_flag='1'"
            Rs.Open sql, m_objCon, adOpenDynamic, adLockOptimistic
            If Rs.RecordCount = 0 Then
                AppendRtn "1", "单据已经制单或记账,不能修改!", id
            ElseIf CInt(Rs!success_flag) = 0 Then
                'AppendRtn "0", "尚未指定成功标志!", id
            Else
                Rs!success_flag = 0
                Rs.Update
                'AppendRtn "0", "成功删除成功标志!", id
            End If
            Rs.Close
        End If
    Next
    Rs.Update
    Exit Sub
End Sub

'去掉导出标志
Private Sub Delete()
'必须是未记账,未制单的记录才能进行
    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 importexport_flag from fd_transactions where transactions_id='" & id & "' and importexport_flag='2'"
            Rs.Open sql, m_objCon, adOpenDynamic, adLockOptimistic
            If Rs.RecordCount = 0 Then
                AppendRtn "1", "单据编号错误!", id
            Else
                Rs!importexport_flag = 0
                Rs.Update
                'AppendRtn "0", "成功删除导出标志!", id
            End If
            Rs.Close
        End If
    Next
    Exit Sub
End Sub


'获取查询条件
Private Function sCondition() As String
    Dim rootTag As String
    Dim node As IXMLDOMNode
    Dim Rs As New ADODB.Recordset
    Dim fld As ADODB.Field
    Dim vchstyle As String
    Dim tmp As String
    
    rootTag = GetAttributeVal("roottag", m_objXmlIn.documentElement)
    '查询条件只能是在fd_transactions范围内
    Rs.Open "select * from fd_transactions where 1>1", m_objCon, adOpenForwardOnly, adLockReadOnly
    sCondition = ""
    For Each node In m_objXmlIn.documentElement.selectSingleNode("//" & rootTag).childNodes
        If node.nodeType = NODE_ELEMENT Then
            tmp = GetAttributeVal("name", node)
            tmp = GetFieldName(tmp, m_objExport)
            If tmp <> "vchstyle" Then
                '是否要调整字段
                'tmp = AdjustField(tmp, node)
                Set fld = Rs(tmp)
                If Not IsNull(fld) Then
                    sCondition = sCondition & fld.Name & GetAttributeVal("operation", node)
                    Select Case fld.Type
                        Case adBSTR, adDate, adDBDate, adDBTime, adDBTimeStamp, adLongVarChar, adLongVarBinary, adBSTR, adLongVarChar, adVarChar, adVarWChar, adWChar
                            sCondition = sCondition & "'" & GetAttributeVal("value", node) & "'"
                        Case Else
                            sCondition = sCondition & GetAttributeVal("value", node)
                    End Select
                    sCondition = sCondition & " " & GetAttributeVal("logic", node) & " "
                End If
            'vchstyle字段特殊处理
            Else
                vchstyle = GetAttributeVal("value", node)
            End If
        End If
    Next
    '必须是已经审核,而且是为记账或制单的记录才能入选
    If sCondition <> "" Then
        sCondition = " importexport_flag='0' and check_name  is not null and pz_code is null and book_name is null and " & sCondition
    End If
    
    If vchstyle = "" Then
    ElseIf Not IsNull(vInRecord("select * from fd_entities where iBIType = '" & vchstyle & "'", m_objCon)) Then
        sCondition = sCondition & " and substring(fd_Transactions.transactions_id,1,2)='" & vchstyle & "' "
    Else
        Err.Raise 3333, "错误的单据类型编号!"
        Exit Function
    End If
End Function

'返回信息中加入节点
Private Sub AppendRtn(sCode As String, sDesc As String, Optional ByVal sKey As String = "")
    Dim node As IXMLDOMElement
    Set node = m_objRtn.createElement("item")
    node.setAttribute "succ", sCode
    node.setAttribute "desc", sDesc
    node.setAttribute "id", sKey
    m_objRtn.documentElement.appendChild node
End Sub

'将一条记录集转换为xml节点
Private Sub appendNode(Rs As ADODB.Recordset, con As ADODB.Connection)
    Dim root As IXMLDOMElement
    Dim node As IXMLDOMElement
    Dim child As IXMLDOMElement
    Dim tmp As IXMLDOMNode
    Dim str As String
    Dim fld As ADODB.Field
    
    Set node = m_objXmlOut.createElement(sRootTag(m_objXmlOut))
    Set root = m_objExport.documentElement.selectSingleNode("//" & sRootTag(m_objExport))
    
    '设置node的值,参照对应字段
    For Each tmp In root.childNodes
        If tmp.nodeType = NODE_ELEMENT Then
            '加入子节点
            str = Trim(tmp.Text)
            Set child = m_objXmlOut.createElement(str)
            
            '如果为空是以后要使用的
            Set fld = Rs(str)
            If Not IsNull(fld) And Not IsNull(fld.Value) And Not IsEmpty(fld.Value) Then
                child.Text = CStr(fld.Value)
            End If
         
            node.appendChild child
        End If
    Next
    '设置输出标志
    con.Execute "update fd_transactions set importexport_flag='2' where transactions_id =  '" & Rs!transactions_id & "'"
    '加入节点
    m_objXmlOut.documentElement.appendChild node
End Sub

'将一个节点转换为一条记录
Private Sub AppendRecord(node As IXMLDOMElement, Rs As ADODB.Recordset, chk As ADODB.Recordset)
    '合法性检查
    On Error GoTo last
    Dim tmp As IXMLDOMNode
    Dim root As IXMLDOMElement
    Dim idMgr As New U8FDMgr.OIDManager
    Dim sFieldName As String
    Dim child As IXMLDOMElement
    Dim negtive As String
    Dim id As String
    Dim ept As String
    Dim schk As String
    
    Rs.AddNew
    '加入主关键字
    id = idMgr.GetNewOID(m_objCon.ConnectionString, CInt(m_sVchStyle), True)
    Rs("transactions_id") = id
    Rs("transactions_code") = mID(id, 6, 15)
    m_sTranCode = mID(id, 6, 15)
    
    '检查编号是否冲突
    AdjustField "transactions_code", Nothing
  
    Set root = m_objImport.documentElement.selectSingleNode("//" & sRootTag(m_objImport))
    For Each tmp In root.childNodes
        If tmp.nodeType = NODE_ELEMENT Then
            sFieldName = tmp.nodename
            If sFieldName <> "" And tmp.Text <> "" Then
                Set child = node.selectSingleNode(tmp.Text)
                ept = GetAttributeVal("empty", tmp)
                If ept = "0" And child.Text = "" Then
                    Rs.CancelUpdate
                    AppendRtn "1", "要求字段" & tmp.nodename & "不能为空!", GetElementVal("iId", node)
                    Exit Sub
                End If
                CheckType chk, sFieldName, child
                schk = GetAttributeVal("check", tmp)
                If schk = "1" Then
                    sFieldName = AdjustField(sFieldName, child, GetElementVal(("iId"), node))
                End If
                If sFieldName <> "" And child.Text <> "" Then
                    Rs(sFieldName) = child.Text
                End If
            End If
        End If
    Next
    '设置导入标记
    Rs("importexport_flag") = "1"
    Rs.Update
    'AppendRtn "0", "成功导入单据!", GetElementVal(("iID"), node)
    Exit Sub
last:
'    AppendRtn "1", "错误原因:" & Error, GetElementVal(("iId"), node)
    Rs.CancelUpdate
End Sub


'校正字段名称
Private Function AdjustField(str As String, node As IXMLDOMElement, Optional key As String) As String
    Dim tmp As Variant
    Select Case str
        Case "transactions_code"
            Dim sql As String
            sql = "select 1 from fd_transactions where substring(transactions_id,1,2)='" & m_sVchStyle & "' and transactions_code = '" & m_sTranCode & "'"
            If Not IsNull(vInRecord(sql, m_objCon)) Then
                AppendRtn "1", "同类型单据编号冲突!", key
                Err.Raise 333
            End If
        Case "rcv_acc_code"
            AdjustField = "rcv_acc_id"
            '如果编号为空,不检查
            If node.Text <> "" Then
                tmp = vInRecord("select iid from fd_accdef where caccid = '" & node.Text & "' and bdestroy<>'1' and istate<>'1'", m_objCon)
                If Not IsNull(tmp) Then
                    node.Text = tmp
                Else
                    AppendRtn "1", "指定的账号不可用!", key
                    Err.Raise 333
                End If
            End If
        Case "pay_acc_code"
            AdjustField = "pay_acc_id"
            If node.Text <> "" Then
                tmp = vInRecord("select iid from fd_accdef where caccid = '" & node.Text & "' and bdestroy<>'1' and istate<>'1'", m_objCon)
                If Not IsNull(tmp) Then
                    node.Text = tmp
                Else
                    AppendRtn "1", "指定的账号不可用!", key
                    Err.Raise 333
                End If
            End If
        Case "invoice_code"
            AdjustField = "invoice_code"
            If Not IsNull(vInRecord("select invoice_code from fd_transactions where invoice_code = '" & node.Text & "'", m_objCon)) Then
                AppendRtn "1", "同编号的单据已经存在了!", key
                Err.Raise 333
            End If
        Case Else
            AdjustField = str
    End Select
End Function

'接口函数
Public Function Transact(sXmlIn As String, sXmlOut As String, Optional objCon As ADODB.Connection) As Boolean
    Transact = False
    If Not bSetTemplate(sXmlIn, 0) Or Not bCon(objCon) Or Not bParse Then
        Transact = False
    Else
        Transact = True
    End If
    
    sXmlOut = XmlOut
    ResetState
End Function

'初始化错误
Private Sub Class_Initialize()
    ResetState
    bSetTemplate sCurrentPath & "xml\export.xml", 2
    bSetTemplate sCurrentPath & "xml\import.xml", 1
End Sub

Private Sub Class_Terminate()
    Set m_objRtn = Nothing
    Set m_objXmlIn = Nothing
    Set m_objImport = Nothing
    Set m_objExport = Nothing
    Set m_objCon = Nothing
End Sub

'重新设置输入输出参数
Private Sub ResetState()
    m_objXmlIn.Load ""
    m_objRtn.loadXML "<ufinterface roottag='fd' proc='rtn'/>"
    m_objXmlOut.loadXML "<ufInterface roottag='fd' proc='export'/>"
End Sub