项目附表显示.frm

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

End Sub

Private Sub AddNew()
    Dim Row As Integer
    Dim Node As IXMLDOMElement
    
    m_iFlag = 1
    
    '获取当前行数
    Row = ocxCell.GetRows(0)
    
    If GetHead("sum") <> "" Then    '如果有合计
        If Row > 1 Then
            ocxCell.SetRows Row - 1, 0
            Row = Row + 1
        Else
            Row = Row + 2
        End If
        ocxCell.SetRows Row, 0
    Else    '如果没有
        Row = Row + 1
        ocxCell.SetRows Row, 0
    End If
    MakeSum
    
    SetButtonState
    
    If m_objContent Is Nothing Then
        Set m_objContent = m_objAid.objGenerateUFDom("roottag", "fd")
    End If
    
    Set Node = m_objAid.objMakeNode("item", "changed", "1")
    m_objAid.objSelectRootTag(m_objContent).appendChild Node
    
End Sub

Private Sub Cancel()
    If iCheck = vbCancel Then
        Exit Sub
    End If
    Set m_objChanged = New Collection
    m_iFlag = 0
    SetButtonState
End Sub

'不支持多选
Private Sub DeleteData()
    Dim old As Integer  '保存上次操作
    Dim AddOn As New U8BudgetMgr.clsAddOnImp
    Dim doc As DOMDocument
    Dim root As IXMLDOMElement
    Dim Node As IXMLDOMElement
    
    If ocxCell.GetRows(0) - 1 = m_iRow And GetHead("sum") <> "" Then
        iShowMsg "不能删除合计行!"
        Exit Sub
    End If
    
    If iShowMsg("确定删除数据吗?", vbYesNo) = vbNo Then
        Exit Sub
    End If
    old = m_iFlag
    m_iFlag = 3
    
    Set doc = m_objAid.objGenerateUFDom("proc", "delete", "roottag", "fd")
    Set root = m_objAid.objSelectRootTag(doc)
    root.setAttribute "table", GetHead("table")
    Set Node = m_objAid.objSelectRootTag(m_objContent).childNodes(m_iRow - 1)
    root.appendChild Node
    
    On Error Resume Next
    If m_objAid.GetAttributeVal("changed", Node) = "" Then '已经保存了的项目
        AddOn.Transact doc, doc, zjLogInfo
        If m_objAid.iSuccess(doc) <> 0 Then
            frmExportInfo.SetInfo doc.xml
            frmExportInfo.Show vbModal
            Exit Sub
        End If
    End If
    
    '删除这个节点;
    m_objAid.objSelectRootTag(m_objContent).removeChild Node
    ocxCell.DeleteRow m_iRow, 1, 0
    
    If GetHead("sum") <> "" And ocxCell.GetRows(0) = 2 Then
        ocxCell.SetRows 1, 0
    End If
    
    If m_objChanged.count = 0 Then
        m_iFlag = 0
    Else
        m_iFlag = old
    End If
    
    GetSum
    SetButtonState
End Sub

Private Sub SetChange()
    '修改
    If m_iFlag = 1 Or ocxCell.GetRows(0) = 1 Then
        Exit Sub
    End If
    m_iFlag = 2
    SetButtonState
End Sub

Private Sub Query()
    Dim AddOn As New U8BudgetMgr.clsAddOnImp
    Dim doc As DOMDocument
    Dim root As IXMLDOMElement
    
    Set m_objContent = m_objAid.objGenerateUFDom("proc", "query")
    m_objContent.documentElement.setAttribute "roottag", "fd"
    m_objContent.documentElement.appendChild m_objQueryParam
    Set root = m_objAid.objSelectRootTag(m_objContent)
    root.setAttribute "table", GetHead("table")
    AddOn.Transact m_objContent, m_objContent, zjLogInfo
    If m_objAid.iSuccess(m_objContent) <> 0 Or m_objAid.iNodeCount(m_objAid.objSelectRootTag(m_objContent)) = 0 Then
        Set m_objContent = Nothing
    End If
    DomToTable
End Sub

'报表求小计
Private Sub GetSum(Optional mode As String)
    Dim sumname As String
    Dim sumcol As Integer
    Dim Row As Integer
    Dim i As Integer
    Dim sumval As Double
    
    Row = ocxCell.GetRows(0)
    sumname = GetHead("sum")
    If Row = 1 Or sumname = "" Then
        Exit Sub
    End If
    sumcol = GetFieldIndex(m_objRef.Item(sumname))
    Row = Row - 2
    For i = 1 To Row
        sumval = sumval + CDbl(GetContent(sumcol, i))
    Next
    ocxCell.SetCellString sumcol, Row + 1, 0, sumval
End Sub

'在单元格数据编辑完成后进行
Private Function iCheck() As Integer
    Dim sparam As String
    iCheck = 0
    If m_iFlag = 0 Then
        Exit Function
    ElseIf m_iFlag = 1 Then
        sparam = "要保存增加的项目吗?"
    Else
        sparam = "要保存项目的修改吗?"
    End If
    iCheck = iShowMsg(sparam, vbYesNoCancel)
    If iCheck = vbNo Then
        Query
        m_iFlag = 0
    ElseIf iCheck = vbYes Then
        SaveData
    Else
    End If
End Function

Private Sub LoadToolPic()
    With IltTool.ListImages
         .clear
         .Add , "print", LoadResPicture(314, vbResBitmap)
         .Add , "preview", LoadResPicture(312, vbResBitmap)
         .Add , "output", LoadResPicture(263, vbResBitmap)
         .Add , "add", LoadResPicture(343, vbResBitmap)
         .Add , "delete", LoadResPicture(347, vbResBitmap)
         .Add , "edit", LoadResPicture(324, vbResBitmap)
         .Add , "cancel", LoadResPicture(316, vbResBitmap)
         .Add , "refresh", LoadResPicture(154, vbResBitmap)
         .Add , "save", LoadResPicture(1145, vbResBitmap)
         .Add , "help", LoadResPicture(396, vbResBitmap)
         .Add , "quit", LoadResPicture(1118, vbResBitmap)
    End With
    
    With tlbTool
         Set .ImageList = IltTool
        
         .Buttons("print").Image = "print"
         .Buttons("preview").Image = "preview"
         .Buttons("output").Image = "output"
         .Buttons("cancel").Image = "cancel"
         .Buttons("add").Image = "add"
         .Buttons("edit").Image = "edit"
         .Buttons("delete").Image = "delete"
         .Buttons("refresh").Image = "refresh"
         .Buttons("save").Image = "save"
         .Buttons("help").Image = "help"
         .Buttons("quit").Image = "quit"
    End With
    
    Me.Icon = LoadResPicture(109, vbResIcon)
End Sub

Private Sub SetButtonState()
    If ocxCell.GetRows(0) = 1 Then  '没有数据
        tlbTool.Buttons("print").Enabled = False
        tlbTool.Buttons("preview").Enabled = False
        tlbTool.Buttons("output").Enabled = False
                
        If m_iMode = 0 Then
            tlbTool.Buttons("add").Enabled = True
            tlbTool.Buttons("edit").Enabled = False
            tlbTool.Buttons("delete").Enabled = False
            tlbTool.Buttons("save").Enabled = False
            tlbTool.Buttons("cancel").Enabled = False
        End If
        
        tlbTool.Buttons("refresh").Enabled = True
    ElseIf m_iFlag <> 0 Then '进行操作
        tlbTool.Buttons("print").Enabled = True
        tlbTool.Buttons("preview").Enabled = True
        tlbTool.Buttons("output").Enabled = True
        
        If m_iMode = 0 Then
            If m_iFlag = 1 Then
                tlbTool.Buttons("add").Enabled = True
            Else
                tlbTool.Buttons("add").Enabled = False
            End If
            tlbTool.Buttons("edit").Enabled = False
            tlbTool.Buttons("delete").Enabled = False
            tlbTool.Buttons("save").Enabled = True
            tlbTool.Buttons("cancel").Enabled = True
        End If
        
        tlbTool.Buttons("refresh").Enabled = False
    Else    '没有操作
        tlbTool.Buttons("print").Enabled = True
        tlbTool.Buttons("preview").Enabled = True
        tlbTool.Buttons("output").Enabled = True
        
        If m_iMode = 0 Then
            tlbTool.Buttons("add").Enabled = True
            tlbTool.Buttons("edit").Enabled = True
            tlbTool.Buttons("delete").Enabled = True
            tlbTool.Buttons("save").Enabled = False
            tlbTool.Buttons("cancel").Enabled = False
        End If
        
        tlbTool.Buttons("refresh").Enabled = True
    End If
End Sub

Private Sub PrintMe()
    If Not m_objContent Is Nothing Then
        ocxCell.PrintLabel 1, 1
        ocxCell.PrintPara 1, 0, 1, 1
        ocxCell.PrintSheet 1, 0
    End If
End Sub

Private Sub Preview()
    If Not m_objContent Is Nothing Then
        ocxCell.PrintLabel 1, 1
        ocxCell.PrintPara 1, 0, 1, 1
        ocxCell.PrintPreview 1, 0
    End If
End Sub

Private Sub Output()
    Dim doc As DOMDocument
    Dim root As IXMLDOMElement
    
    On Error Resume Next
    comFile.Filename = ""
    comFile.DefaultExt = "xls"
    comFile.Flags = cdlOFNOverwritePrompt Or cdlOFNPathMustExist Or cdlOFNLongNames Or cdlOFNExtensionDifferent Or cdlOFNHideReadOnly
    comFile.Filter = "Text Files(*.txt)|*.txt|Excel Files(*.xls)|*.xls|Html Files(*.html)|*.html|Xml Files(*.xml)|*.xml|Mdb Files(*.mdb)|*.mdb"
    comFile.FilterIndex = 1
    comFile.ShowSave
    ocxCell.PrintPara 1, 0, 1, 1
    If Trim(comFile.Filename) <> "" And Not m_objContent Is Nothing Then
        Select Case comFile.FilterIndex
            Case 1 '文本文件
                If ocxCell.ExportTextFile(" ", comFile.Filename, 0) = 0 Then
                    iShowMsg "输出失败!"
                Else
                    iShowMsg "输出成功!"
                End If
            Case 2 'excel文件
                If ocxCell.ExportExcelFile(comFile.Filename) = 0 Then
                    iShowMsg "输出失败!"
                Else
                    iShowMsg "输出成功!"
                End If
            Case 3 'html文件
                If ocxCell.ExportHtmlFile(comFile.Filename) = 0 Then
                    iShowMsg "输出失败!"
                Else
                    iShowMsg "输出成功!"
                End If
            Case 4 'xml文件
                Set doc = m_objAid.objGenerateUFDom("roottag", "fd")
                Set root = m_objAid.objSelectRootTag(doc)
                root.appendChild m_objHead.documentElement
                root.appendChild m_objContent.documentElement
                doc.Save comFile.Filename
                If Err.Number <> 0 Then
                    iShowMsg "输出失败!"
                Else
                    iShowMsg "输出成功!"
                End If
            Case 5 '
                If Not bRsToMdb(comFile.Filename, "select * from " & GetHead("table") & " where cAutoName='" & m_sPlanID & "' and cAutoCode='" & m_sPrjID & "'") Then
                    iShowMsg "输出失败!"
                Else
                    iShowMsg "输出成功!"
                End If
            Case Else
        End Select
    End If
End Sub
            
Private Sub Quit()
    If iCheck = vbCancel Then
        Exit Sub
    Else
        Unload Me
    End If
End Sub

Private Sub Reload()
    Dim rtn As Integer
    
    rtn = iCheck
    If rtn = vbCancel Then
        Exit Sub
    ElseIf rtn = 0 Then
        Query
    End If
    m_iFlag = 0
End Sub

Private Sub help()
    
End Sub