业务通用模块.bas

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

'If bHasTblBodyFoot Then     '如果表格中有数字或者金额列，那么表体尾显示合计值
'    Set iXmlDataTable = oXmlData.createElement("表体尾")
'    iXmlDataNode.appendChild iXmlDataTable
'
'    Set iXmlStyleLeaf = oXmlStyle.createElement("表体尾")
'    iXmlStyleNode.appendChild iXmlStyleLeaf
'    iXmlStyleLeaf.setAttribute "对齐方式", "中"
'    iXmlStyleLeaf.setAttribute "边框风格", "783"
'    iXmlStyleLeaf.setAttribute "边框宽度", "2"
'    iXmlStyleLeaf.setAttribute "行高", "50"
'    iXmlStyleLeaf.setAttribute "字体名", "宋体"
'    iXmlStyleLeaf.setAttribute "字体大小", "10"
'    iXmlStyleLeaf.setAttribute "粗体", "是"
'    iXmlStyleLeaf.setAttribute "颜色", "#0000AA"
'
'    For i = 0 To SGD.Cols - 1
'        If InStr(SGD.TextMatrix(0, i), "选择") = 0 Then
'            Set iXmlDataLeaf = oXmlData.createElement("单元")
'            iXmlDataTable.appendChild iXmlDataLeaf
'            If SGD.ColAlignment(i) = 7 Then         '请注意第一列就是数字的情况,小计将显示在别的列
'                iXmlDataLeaf.Text = "%PAGE_SUM_F%"
'            ElseIf Not bSum Then
'                iXmlDataLeaf.Text = "本页合计"
'                bSum = True
'            Else
'                iXmlDataLeaf.Text = ""
'            End If
'        End If
'    Next i
'End If
'
'Set iXmlDataNode = oXmlData.createElement("表尾")
'iXmlDataTask.appendChild iXmlDataNode
'
'Set iXmlStyleNode = oXmlStyle.createElement("表尾")
'iXmlStyleFoot.appendChild iXmlStyleNode
'iXmlStyleNode.setAttribute "字体名", "宋体"
'iXmlStyleNode.setAttribute "字体大小", "10"
''iXmlStyleNode.setAttribute "粗体", "是"
'iXmlStyleNode.setAttribute "颜色", "#800000"
'
'For i = 0 To UBound(TableFoot)
'    Set iXmlDataLeaf = oXmlData.createElement("字段")
'    iXmlDataNode.appendChild iXmlDataLeaf
'    If TableFoot(i)(0) <> "" Then
'        iXmlDataLeaf.setAttribute "名字", TableFoot(i)(0)
'    End If
'    iXmlDataLeaf.Text = TableFoot(i)(1)
'
'    Set iXmlStyleLeaf = oXmlStyle.createElement("字段")
'    iXmlStyleNode.appendChild iXmlStyleLeaf
''    iXmlStyleLeaf.setAttribute "打印", "否"
'    iXmlStyleLeaf.setAttribute "名字", TableFoot(i)(0)
'    iXmlStyleLeaf.setAttribute "字体名", "宋体"
'    iXmlStyleLeaf.setAttribute "字体大小", "10"
'    If i = UBound(TableFoot) Then
'        iXmlStyleLeaf.setAttribute "页面居右", "是"
'        iXmlStyleLeaf.setAttribute "对齐方式", "右"
'    Else
'        iXmlStyleLeaf.setAttribute "对齐方式", "左"
'    End If
'    iXmlStyleLeaf.setAttribute "左顶点", CStr(i * 600) & ", "
'    iXmlStyleLeaf.setAttribute "宽", "500"
'    iXmlStyleLeaf.setAttribute "高", "100"
'Next i
'
'Set iXmlDataNode = oXmlData.createElement("页脚")
'iXmlDataTask.appendChild iXmlDataNode
'iXmlDataNode.Text = PageFoot
'
'Set iXmlStyleNode = oXmlStyle.createElement("页脚")
'iXmlStyleFoot.appendChild iXmlStyleNode
'iXmlStyleNode.setAttribute "对齐方式", "右"
'iXmlStyleNode.setAttribute "左顶点", "0,2400"
'iXmlStyleNode.setAttribute "宽", "0"
'iXmlStyleNode.setAttribute "高", "100"
'iXmlStyleNode.setAttribute "字体名", "楷体_GB2312"
'iXmlStyleNode.setAttribute "字体大小", "10"
'iXmlStyleNode.setAttribute "颜色", "#99598E"
'
'strXmlData = "<?xml version=""1.0"" standalone=""yes"" ?>" & oXmlData.xml
'strXmlStyle = "<?xml version=""1.0"" standalone=""yes"" ?>" & oXmlStyle.xml
'
'SuperGridToXml = True
'End Function

Public Function bOutputAsMdb(strID As String, strFileName As String) As Boolean
    Dim objDoc As DOMDocument
    Dim objRoot As IXMLDOMElement
    Dim strSql As String
    Dim objCat As New ADOX.Catalog
    Dim objtbl As ADOX.Table
    Dim objRs As ADODB.Recordset
    Dim objDst As ADODB.Recordset
    Dim objCon As ADODB.Connection
    Dim iPos As Integer
    Dim objFld As ADODB.Field
    Dim size As Integer
    Dim iMaxLen As Integer
    Dim objTypeRef As IXMLDOMElement
    Dim objNode As IXMLDOMElement
    Dim strTableName As String
    
    On Error GoTo last
    bOutputAsMdb = False
    
    '如果文件存在覆盖
    strFileName = Trim(strFileName)
    If strFileName <> "" And Len(Dir(strFileName)) <> 0 Then
        Kill strFileName
    End If
    objCat.Create "Provider=Microsoft.Jet.OLEDB.3.51;User ID=;Data Source=" & strFileName
    Set objCon = m_objAid.objOpenDB(zjLogInfo.UfDbName)
    
    '装入导出rs的查询
    m_objAid.LoadFromTemplate "budgetmgr/field_ref ", objDoc '字段类型对照"
    Set objTypeRef = m_objAid.objSelectRootTag(objDoc)
    
    m_objAid.LoadFromTemplate "budgetmgr/sql_ref", objDoc
    Set objRoot = m_objAid.objSelectRootTag(objDoc)
    
    '导出头
    strTableName = Trim(InputBox("请填写要输出的主表名!", "数据库输出!"))
    If strTableName = "" Then
        Err.Raise 1
    End If
    
    If Not bRsToMdb(strFileName, "select * from fd_budgethead where iid=" & strID, strTableName, objCat, objCon, objRoot, objTypeRef) Then
        Err.Raise 1
        Exit Function
    End If
    
    '导出体
    strTableName = Trim(InputBox("请填写要输出的子表名!", "数据库输出!"))
    If strTableName = "" Then
        Err.Raise 1
    End If
        
    If Not bRsToMdb(strFileName, "select * from fd_budgetdata where iid=" & strID, strTableName, objCat, objCon, objRoot, objTypeRef) Then
        Err.Raise 1
        Exit Function
    End If
'    iMaxLen = CInt(m_objAid.GetAttributeVal("maxtextlen", objRoot))
'
''    '导出头部表
'    Set objtbl = New ADOX.Table
'    objtbl.Name = "fd_budgethead"
'    strSql = m_objAid.GetAttributeVal("sql", objRoot.selectSingleNode("head")) & " where iid=" & strID
'    Set objRs = objCon.Execute(strSql)
'
'    '建立表结构
'    For iPos = 0 To objRs.Fields.count - 1
'        Set objFld = objRs.Fields(iPos)
'        size = objFld.DefinedSize
'        Set objNode = objTypeRef.selectSingleNode("t" & objFld.Type)
'        If objNode Is Nothing Then
'            objtbl.Columns.Append objFld.Name, objFld.Type, IIf(size > iMaxLen, iMaxLen, size)
'        Else
'            size = size * CInt(m_objAid.GetAttributeVal("factor", objNode))
'            objtbl.Columns.Append objFld.Name, CInt(m_objAid.GetAttributeVal("ref", objNode)), IIf(size > iMaxLen, iMaxLen, size)
'        End If
'    Next
'    objCat.Tables.Append objtbl
'
'    '添加数据
'    Set objDst = New adodb.Recordset
'    objDst.Open "select * from fd_budgethead where 1>1", objCat.ActiveConnection, adOpenDynamic, adLockOptimistic
'    While Not objRs.EOF
'        objDst.AddNew
'        For iPos = 0 To objtbl.Columns.count - 1
'            Set objFld = objRs(objtbl.Columns(iPos).Name)
'            If IsNull(objFld.Value) Then
'            ElseIf objFld.Type = adBoolean Then
'                objDst(objFld.Name) = IIf(objFld.Value, 1, 0)
'            Else
'                objDst(objFld.Name).Value = objFld.Value
'            End If
'        Next
'        objDst.Update
'        objRs.MoveNext
'    Wend
'    objDst.Close
    
'    '导出表体
'    Set objtbl = New ADOX.Table
'    objtbl.Name = "fd_budgetdata"
'    strSql = m_objAid.GetAttributeVal("sql", objRoot.selectSingleNode("content")) & " where iid=" & strID
'    Set objRs = objCon.Execute(strSql)
'
'    '建立表结构
'    For iPos = 0 To objRs.Fields.count - 1
'        Set objFld = objRs.Fields(iPos)
'        size = objFld.DefinedSize
'        Set objNode = objTypeRef.selectSingleNode("t" & objFld.Type)
'        If objNode Is Nothing Then
'            objtbl.Columns.Append objFld.Name, objFld.Type, IIf(size > iMaxLen, iMaxLen, size)
'        Else
'            size = size * CInt(m_objAid.GetAttributeVal("factor", objNode))
'            objtbl.Columns.Append objFld.Name, CInt(m_objAid.GetAttributeVal("ref", objNode)), IIf(size > iMaxLen, iMaxLen, size)
'        End If
'    Next
'    objCat.Tables.Append objtbl
    '添加数据
'    objDst.Open "select * from fd_budgetdata where 1>1", objCat.ActiveConnection, adOpenDynamic, adLockOptimistic
'    While Not objRs.EOF
'        objDst.AddNew
'        For iPos = 0 To objtbl.Columns.count - 1
'            Set objFld = objRs(objtbl.Columns(iPos).Name)
'            If IsNull(objFld.Value) Then
'            ElseIf objFld.Type = adBoolean Then
'                objDst(objFld.Name) = IIf(objFld.Value, 1, 0)
'            Else
'                objDst(iPos) = objFld.Value
'            End If
'        Next
'        objDst.Update
'        objRs.MoveNext
'    Wend
    
    bOutputAsMdb = True
    Exit Function
last:
    On Error Resume Next
    If strFileName <> "" And Len(Dir(strFileName)) <> 0 Then
        Kill strFileName
    End If
    Err.clear
End Function


Public Function bRsToMdb(strFileName As String, strWhere As String, Optional strTableName As String, Optional objCat As ADOX.Catalog, Optional objCon As ADODB.Connection, Optional objRoot As IXMLDOMElement, Optional objTypeRef As IXMLDOMElement, Optional strTableStyle As String) As Boolean
    Dim objtbl As ADOX.Table
    Dim objDst As ADODB.Recordset
    Dim objNode As IXMLDOMElement
    Dim iMaxLen As Integer
    Dim objDoc As DOMDocument
    Dim objRs As ADODB.Recordset
    Dim strSql As String
    Dim iPos As Integer
    Dim size As Integer
    Dim objFld As ADODB.Field
    
    On Error GoTo last
    bRsToMdb = False
    strFileName = Trim(strFileName)
    strTableStyle = Trim(strTableStyle)
    strWhere = Trim(strWhere)
    
    If Not objCat Is Nothing Then
    
    ElseIf strFileName <> "" And Len(Dir(strFileName)) <> 0 Then
        Kill strFileName
    End If
    
    '获取表名
    If strTableName = "" Then
        strTableName = Trim(InputBox("请填写要输出的表名!", "数据库输出!"))
        If strTableName = "" Then
            Err.Raise 1
        End If
    End If
    
    If objCat Is Nothing Then
        Set objCat = New ADOX.Catalog
        objCat.Create "Provider=Microsoft.Jet.OLEDB.3.51;User ID=;Data Source=" & strFileName
    End If
        
    If objCon Is Nothing Then
        Set objCon = m_objAid.objOpenDB(zjLogInfo.UfDbName)
    End If
    
    If objRoot Is Nothing Then
        m_objAid.LoadFromTemplate "budgetmgr/sql_ref", objDoc
        Set objRoot = m_objAid.objSelectRootTag(objDoc)
    End If
    
    If objTypeRef Is Nothing Then
        m_objAid.LoadFromTemplate "budgetmgr/field_ref ", objDoc '字段类型对照
        Set objTypeRef = m_objAid.objSelectRootTag(objDoc)
    End If
    iMaxLen = CInt(m_objAid.GetAttributeVal("maxtextlen", objTypeRef))
    
    '导出头部表
    If strTableStyle <> "" Then
        strSql = m_objAid.GetAttributeVal("sql", objRoot.selectSingleNode(strTableStyle))
    End If
    If strWhere <> "" Then
        strSql = strSql & " " & strWhere
    End If
    Set objRs = objCon.Execute(strSql)
    
    Set objtbl = New ADOX.Table
    objtbl.Name = strTableName
    For iPos = 0 To objRs.Fields.count - 1
        Set objFld = objRs.Fields(iPos)
        size = objFld.DefinedSize
        Set objNode = objTypeRef.selectSingleNode("t" & objFld.Type)
        If objNode Is Nothing Then
            objtbl.Columns.Append objFld.Name, objFld.Type, IIf(size > iMaxLen, iMaxLen, size)
        Else
            size = size * CInt(m_objAid.GetAttributeVal("factor", objNode))
            objtbl.Columns.Append objFld.Name, CInt(m_objAid.GetAttributeVal("ref", objNode)), IIf(size > iMaxLen, iMaxLen, size)
        End If
    Next
    
    objCat.Tables.Append objtbl
    
    '添加数据
    Set objDst = New ADODB.Recordset
    objDst.Open "select * from " & strTableName & " where 1>1", objCat.ActiveConnection, adOpenDynamic, adLockOptimistic
    While Not objRs.EOF
        objDst.AddNew
        For iPos = 0 To objtbl.Columns.count - 1
            Set objFld = objRs(objtbl.Columns(iPos).Name)
            If IsNull(objFld.Value) Then
            ElseIf objFld.Type = adBoolean Then
                objDst(objFld.Name) = IIf(objFld.Value, 1, 0)
            Else
                objDst(objFld.Name).Value = objFld.Value
            End If
        Next
        objDst.Update
        objRs.MoveNext
    Wend
    bRsToMdb = True
    Exit Function
last:
    strFileName = Trim(strFileName)
    If strFileName <> "" And Len(Dir(strFileName)) <> 0 Then
        Kill strFileName
    End If
    Err.clear
End Function

Public Function objShowCommonRef(strSql As String, strFieldName As String, Optional bMultiSel As Boolean = False, Optional strGrade As String = "") As ADODB.Recordset
    Dim objRef As New UFReferC.UFReferClient
    
    objRef.StrRefInit zjLogInfo, bMultiSel, "", strSql, strFieldName
    objRef.Show
    
    Set objShowCommonRef = objRef.recmx
    Set objRef = Nothing
End Function

Public Sub ShowDateRef(objText As Object, Optional lngHwnd As Long = 0)
    Dim objCalendar As New CalendarAPP.ICaleCom
    
    objCalendar.left = objText.left
    objCalendar.top = objText.top
    objCalendar.DateDivideChar = "-"
    objCalendar.OrgDate = IIf(IsDate(objText), objText, Date)
    objCalendar.Caption = "日历"                         '设置日历标题
    objText.Text = Format(objCalendar.Calendar(IIf(lngHwnd = 0, objText.Parent.hWnd, lngHwnd)), "yyyy-mm-dd")           '显示日历并返回选定日期
    Set objCalendar = Nothing
End Sub


Public Function vCheckExist(strMode As String, strVal As String)
    Dim Node As IXMLDOMElement
    
    Set Node = m_objRefTree.documentElement.selectSingleNode(strMode)
    If Not Node Is Nothing Then
        vCheckExist = m_objAid.vInRecord(Node.getAttribute("check") & "'" & strVal & "'", m_objAid.objOpenDB(g_sDataSourceName))
    End If
End Function

Public Function FillWithDot(strTmp As String) As String
    Dim iStart As Integer
    Dim iStop As Integer
    Dim tmp As String
    
    iStart = 1
    iStop = InStr(1, strTmp, ",")
    While iStop <> 0
        tmp = mID(strTmp, iStart, iStop - iStart)
        FillWithDot = FillWithDot & "'" & tmp & "',"
        iStart = iStop + 1
        iStop = InStr(iStart, strTmp, ",")
    Wend
    '处理最后一个
    FillWithDot = FillWithDot & "'" & mID(strTmp, iStart) & "'"
End Function

Public Function iShowMsg(strMsg As String, Optional iType As Integer = -1, Optional strTitle As String = "") As Integer
    If Trim(strTitle) = "" Then
        strTitle = "提示信息!"
    End If

    iShowMsg = MsgBox(strMsg, iType, strTitle)
End Function