指定附表.frm

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

End Sub

Private Sub cmdCancel_Click()
    Unload Me
End Sub

Private Sub cmdChange_Click()
    SetEdit
    m_bChange = True
End Sub

Private Sub cmdOk_Click()
    If m_objTable Is Nothing Then
        Exit Sub
    End If
    AppendNode
    Unload Me
End Sub

'删除全部
Private Sub cmdRemoveAll_Click()
    MoveItem False, True
End Sub

'删除一部分
Private Sub cmdRemoveOne_Click()
    MoveItem False
End Sub

Private Sub MoveItem(direct As Boolean, Optional all As Boolean = False)
    Dim i As Integer
    
    On Error Resume Next
    '添加
    If direct Then
        '全部吗
        If all Then
            For i = 0 To lstAll.ListCount - 1
                lstChosen.AddItem lstAll.List(i)
            Next
            lstAll.clear
        Else
            While i < lstAll.ListCount
                If lstAll.Selected(i) Then
                    lstChosen.AddItem lstAll.List(i)
                    lstAll.RemoveItem i
                Else
                    i = i + 1
                End If
            Wend
        End If
    Else
        If all Then
            While i < lstChosen.ListCount
'                If Not IsNecessary("f" & lstChosen.List(i)) Then
                lstAll.AddItem lstChosen.List(i)
                lstChosen.RemoveItem i
'                End If
            Wend
            cboSum.Text = ""
'            lstChosen.clear
        Else
            While i < lstChosen.ListCount
                If lstChosen.Selected(i) And Not IsNecessary("f" & lstChosen.List(i)) Then
                    lstAll.AddItem lstChosen.List(i)
                    If lstChosen.List(i) = cboSum.Text Then
                        cboSum.Text = ""
                    End If
                    lstChosen.RemoveItem i
                Else
                    i = i + 1
                End If
            Wend
        End If
    End If
End Sub




Private Sub Form_Load()
    SetState
    SetPassive
    Me.Icon = LoadResPicture(109, vbResIcon)
End Sub

'保存对应数据,只保存选中的字段
Private Sub AppendNode()
    Dim doc As DOMDocument
    Dim Node As IXMLDOMElement
    Dim root As IXMLDOMElement
    Dim i As Integer
    Dim count As Integer
    Dim con As ADODB.Connection
    Dim used As VB.ListBox
    Dim mode As String
    Dim AddOn As New U8BudgetMgr.clsAddOnImp
    
    On Error GoTo last
    '如果没有修改
    If Not m_bChange Then
        Exit Sub
    End If
    
    '如果表名为空,直接退出
    If Trim(cboTableName.Text) = "" Or lstChosen.ListCount = 0 Then
        Set doc = m_objAid.objGenerateUFDom("roottag", "fd", "proc", "settable")
        Set root = m_objAid.objSelectRootTag(doc)
        root.setAttribute "mode", "none"
        root.setAttribute "iprjid", iid
    Else
        
'        '设定最小的listbox
'        If lstChosen.ListCount <= lstAll.ListCount Then
'            mode = "sel"
'            Set used = lstChosen
'        Else
'            mode = "desel"
'            Set used = lstAll
'        End If
        Set used = lstChosen
        mode = "sel"
        
        '创建返回文档
        Set Node = m_objTable.documentElement.selectSingleNode("t" & Trim(cboTableName.Text))
        Set doc = m_objAid.objGenerateUFDom("roottag", "fd", "proc", "settable")
        Set root = m_objAid.objSelectRootTag(doc)
        
        root.setAttribute "table", m_objAid.GetAttributeVal("name", Node)
        root.setAttribute "tablename", Trim(cboTableName.Text)
        root.setAttribute "tablecode", m_objAid.GetAttributeVal("code", Node)
        root.setAttribute "mode", mode
        root.setAttribute "iprjid", iid
        
        If cboSum.Text <> "" Then
            root.setAttribute "sum", m_objAid.GetAttributeVal("name", m_objField.documentElement.selectSingleNode("f" & cboSum.Text))
            root.setAttribute "sumname", cboSum.Text
        End If
        
        count = used.ListCount - 1
        If count = -1 Then
        Else
            '根据节点中文名获取英文名,英文名是不变的,中文名可变
            
            For i = 0 To count
'                Set node = m_objAid.objMakeNode("f" & used.List(i))
                Set Node = m_objField.documentElement.selectSingleNode("f" & used.List(i))
                If Not Node Is Nothing Then
                    root.appendChild Node
                End If
            Next
        End If
    End If
    
    AddOn.Transact doc, doc, zjLogInfo
    If m_objAid.iSuccess(doc) Then
        frmExportInfo.SetInfo doc.xml
        frmExportInfo.Show vbModal
    End If
    m_bChange = False
    Exit Sub
last:
    Err.clear
End Sub


Private Sub lstAll_DblClick()
    If lstAll.SelCount <> 0 Then
        cmdAddOne_Click
    End If
End Sub


Private Sub lstChosen_DblClick()
    If lstChosen.SelCount <> 0 Then
        cmdRemoveOne_Click
    End If
End Sub

Private Sub SetState()
    '提取项目定义信息
    Dim con As ADODB.Connection
    Dim rs As ADODB.Recordset
    Dim sql As String
    Dim Cur As DOMDocument
    Dim root As IXMLDOMElement
    Dim Node As IXMLDOMElement
    Dim mode As String
    Dim i As Long
    Dim prj As New U8BudgetMgr.clsPrjData
    Dim AddOn As New U8BudgetMgr.clsAddOnImp
    
    On Error GoTo last
    
    m_bUsed = False
    '先填充表名
    FillTableName

    Set Cur = m_objAid.objGenerateUFDom("proc", "hasaddon", "roottag", "fd")
    Set root = m_objAid.objSelectRootTag(Cur)
    root.setAttribute "iprjid", iid
    AddOn.Transact Cur, Cur, zjLogInfo
    If m_objAid.iSuccess(Cur) <> 0 Then
        Exit Sub
    End If
    
    '设置界面取值
    Set root = m_objAid.objSelectRootTag(Cur)
    mode = m_objAid.GetAttributeVal("mode", root)

    '获取字段名称
    cboSum.Text = m_objAid.GetAttributeVal("sumname", root)
    cboTableName.Text = m_objAid.GetAttributeVal("tablename", root)
    
    '清空字段信息
    lstAll.clear
    lstChosen.clear
    
    Set root = m_objAid.objSelectRootTag(Cur)
    If Not m_objTable Is Nothing Then
        FillFieldName m_objAid.GetAttributeVal("tablecode", root), mode = "sel"
        
        '填充
'        For Each node In root.childNodes
'            If mode = "desel" Then
'                lstAll.AddItem mID(node.nodename, 2)
'                lstChosen.RemoveItem m_objAid.iItemPos(mID(node.nodename, 2), lstChosen)
'                End If
'            Else
'                lstChosen.AddItem mID(node.nodename, 2)
'                i = m_objAid.iItemPos(mID(node.nodename, 2), lstAll)
'                If i <> -1 Then
'                    lstAll.RemoveItem i
'                End If
'            End If
'        Next
        For Each Node In root.childNodes
            sql = LCase(m_objAid.GetAttributeVal("name", Node))
            If sql <> "cautoname" And sql <> "cautocode" Then
                lstChosen.AddItem mID(Node.nodename, 2)
                lstAll.RemoveItem m_objAid.iItemPos(mID(Node.nodename, 2), lstAll)
            End If
        Next
    End If
    
    prj.id = iid
    If prj.used(g_sDataSourceName) And cboSum.Text <> "" Then
        lbUsed.Visible = True
        m_bUsed = True
    Else
        lbUsed.Visible = False
        m_bUsed = False
    End If
    Exit Sub
last:
    Err.clear
End Sub

Private Sub SetPassive()
    cboTableName.Enabled = False
    cboSum.Enabled = False
    lstAll.Enabled = False
    lstChosen.Enabled = False
    cmdAddOne.Enabled = False
    cmdAddAll.Enabled = False
    cmdRemoveOne.Enabled = False
    cmdRemoveAll.Enabled = False
End Sub

Private Sub SetEdit()
    cboTableName.Enabled = IIf(m_bUsed, False, True)
    cboSum.Enabled = IIf(m_bUsed, False, True)
    lstAll.Enabled = True
    lstChosen.Enabled = True
    cmdAddOne.Enabled = True
    cmdAddAll.Enabled = True
    cmdRemoveOne.Enabled = IIf(m_bUsed, False, True)
    cmdRemoveAll.Enabled = IIf(m_bUsed, False, True)
End Sub

Private Function IsNecessary(str As String)
    Dim Node As IXMLDOMElement
    Dim root As IXMLDOMElement
    Dim tmp As String
    
    On Error Resume Next
    IsNecessary = False
    If m_objTable Is Nothing Or m_objField Is Nothing Then
        Exit Function
    End If
    
    Set root = m_objAid.objSelectRootTag(m_objField)
    Set Node = root.selectSingleNode(str)
    If Not Node Is Nothing Then
        tmp = LCase(m_objAid.GetAttributeVal("name", Node))
        If tmp = "cautoname" Or tmp = "cautocode" Then
            IsNecessary = True
        End If
    End If
End Function