VB财务软件系统下载源代码提供自由下载使用学习

            .Refresh
'            ReDim creClass(.Rows - 2, 3)
'            For i = 0 To .Rows - 2
'                creClass(i, 0) = .TextMatrix(i + 1, 0)
'                creClass(i, 1) = .TextMatrix(i + 1, 1)
'                creClass(i, 2) = .TextMatrix(i + 1, 2)
'                creClass(i, 3) = .TextMatrix(i + 1, 3)
'            Next
            credstat.selRow = .Rows - 1
    End Select
    End With
'    con1.Close
'    Set con1 = Nothing
'    If Not SaveData Then
'        GoTo error0
'    End If
    Exit Sub
error0: MsgBox "删除数据失败！", vbInformation, "操作失败"
'        con1.Close
'        Set con1 = Nothing

End Sub

Private Sub CancelProc()
    Dim i As Integer
    On Error Resume Next
    
    i = UBound(creClass)
    
    If Err.Number <> 0 Then
        setNoDataState
        Err.clear
        Exit Sub
    End If
    
    With SuperGrid1
        .Rows = UBound(creClass) + 2
        For i = 0 To .Rows - 2
            .TextMatrix(i + 1, 0) = creClass(i, 0)
            .TextMatrix(i + 1, 1) = creClass(i, 1)
            .TextMatrix(i + 1, 3) = creClass(i, 3)
            If i <> .Rows - 2 Then
                .TextMatrix(i + 1, 2) = creClass(i, 2)
            Else
                .TextMatrix(i + 1, 2) = ""
            End If
        Next
    End With
    
    With tlbTool
        .Buttons("print").Enabled = Enabled
        .Buttons("preview").Enabled = Enabled
        .Buttons("Output").Enabled = Enabled
        .Buttons("Modi").Enabled = Enabled
        .Buttons("addColumn").Enabled = False
        .Buttons("delColumn").Enabled = False
        .Buttons("Cancel").Enabled = False
        .Buttons("Save").Enabled = False
    End With
    credstat.selRow = SuperGrid1.Rows - 1
    credstat.modified = False
    credstat.ModifyState = 0
    SuperGrid1.ReadOnly = True
End Sub

Private Sub saveProc()
If SaveData Then
    With tlbTool
        .Buttons("print").Enabled = True
        .Buttons("preview").Enabled = True
        .Buttons("Output").Enabled = True
        .Buttons("Modi").Enabled = True
        .Buttons("addColumn").Enabled = False
        .Buttons("delColumn").Enabled = False
        .Buttons("Cancel").Enabled = False
        .Buttons("Save").Enabled = False
    End With
    credstat.modified = False
    credstat.ModifyState = 0
    credstat.selRow = SuperGrid1.Rows - 1
    SuperGrid1.ReadOnly = True
End If
End Sub

'保存数据
Private Function SaveData() As Boolean
    Dim i As Integer
    Dim sqlstr As String
    Dim con1 As New ADODB.Connection
    'Dim rs1 As New ADODB.Recordset

    With SuperGrid1
        For i = 1 To .Rows - 1
            If .TextMatrix(i, 0) = "" Then
                MsgBox "信用等级不能为空！", vbInformation, "输入错误"
                SaveData = False
                Exit Function
            ElseIf dupcreclass(i) Then
                MsgBox "信用等级不能重复！", vbInformation, "输入错误"
                SaveData = False
                Exit Function
            End If
            If .TextMatrix(i, 3) = "" Then
                MsgBox "贷款额度不能为空！", vbInformation, "输入错误"
                SaveData = False
                Exit Function
            ElseIf Not IsNumeric(.TextMatrix(i, 3)) Then
                MsgBox "贷款额度输入必须是数字！", vbInformation, "输入错误"
                SaveData = False
                Exit Function
            ElseIf CDbl(.TextMatrix(i, 3)) < 0 Then
                MsgBox "贷款额度不能为负数！", vbInformation, "输入错误"
                SaveData = False
                Exit Function
            Else
                credstat.selRow = i
                credstat.selcol = 1
                If Not lowBoundProc Then
                    SaveData = False
                    Exit Function
                Else
                    credstat.selcol = 2
                    If Not highBoundProc Then
                        SaveData = False
                        Exit Function
                    End If
                End If
            End If
            If Not check_creClass(i) Then
                SaveData = False
                Exit Function
            End If
        Next
        On Error GoTo error0
        con1.ConnectionString = zjLogInfo.UfDbName
        'con1.ConnectionString = "Provider=SQLOLEDB.1;User ID=SA;Initial Catalog=UFDATA_997_2001;" _
                    & "Data Source=U8LT;Use Procedure for Prepare=1;Auto Translate=True;Packet Size=4096;Workstation ID=U8LT;Use Encryption for Data=False;Tag with column collation when possible=False"
        con1.CursorLocation = adUseClient
        con1.Open
        con1.BeginTrans
        sqlstr = "delete from fd_creClass;"
        con1.Execute sqlstr
        For i = 1 To .Rows - 1
    '        sqlstr = "Select * from Fd_creClass Where creClass='" & .TextMatrix(i, 0) & "'"
    '        rs1.Open sqlstr, con1, adOpenDynamic, adLockOptimistic
    '            If Not (rs1.EOF Or rs1.BOF) Then
    '                rs1("creClass") = .TextMatrix(i, 0)
    '                rs1("lowMark") = .TextMatrix(i, 1)
    '                rs1("highMark") = connumber(.TextMatrix(i, 2))
    '                rs1("borLim") = .TextMatrix(i, 3)
    '                rs1.Update
    '            Else
                    sqlstr = "insert Into Fd_creclass values('" & .TextMatrix(i, 0) & "','" & .TextMatrix(i, 1) & "','" & connumber(.TextMatrix(i, 2), i, 2) & "','" & .TextMatrix(i, 3) & "')"
                    con1.Execute sqlstr
        '            rs1.AddNew
        '            rs1("creClass") = .TextMatrix(i, 0)
        '            rs1("lowMark") = .TextMatrix(i, 1)
        '            rs1("highMark") = .TextMatrix(i, 2)
        '            rs1("borLim") = .TextMatrix(i, 3)
    '            End If
    '        rs1.Close
        Next
        
        con1.CommitTrans
        'MsgBox "数据存储完成！", vbInformation, "数据存储"
        '重新定义后台数组
        ReDim creClass(.Rows - 2, 3)
        For i = 1 To .Rows - 1
            creClass(i - 1, 0) = Trim(.TextMatrix(i, 0))
            creClass(i - 1, 1) = Trim(.TextMatrix(i, 1))
            creClass(i - 1, 2) = Trim(.TextMatrix(i, 2))
            creClass(i - 1, 3) = Trim(.TextMatrix(i, 3))
        Next
    End With

    SaveData = True
    'rs1.Close
    con1.Close
    'Set rs1 = Nothing
    Set con1 = Nothing
     
    Exit Function
error0: con1.RollbackTrans
        'rs1.Close
        con1.Close
     '   Set rs1 = Nothing
        Set con1 = Nothing
        MsgBox "数据存储失败！", vbInformation, "数据存储"
End Function

Private Function dupcreclass(ByVal s As Integer) As Boolean
    Dim i As Integer
    dupcreclass = False
    With SuperGrid1
        For i = 1 To .Rows - 1
            If s <> i Then
                If .TextMatrix(i, 0) = .TextMatrix(s, 0) Then
                    dupcreclass = True
                End If
            End If
        Next
    End With
        
End Function
'初始化打印数据XML文件
Private Sub initPrnXmlFile()
    '过程变量
    Dim prnxml As New clsPrnXml
    Dim AttrName() As String
    Dim AttrValue() As String
    Dim i, j As Integer
    Dim str1 As String
    Dim creData() As String
    On Error GoTo error0
    
    '插入结构数据数据
    str1 = "信用等级"
    prnxml.Initialize "数据", "任务"
    prnxml.InsertPNode "任务", "页眉", "第%p页，共%p页"
    prnxml.InsertPNode "任务", "标题", str1
'    prnxml.InsertPNode "任务", "表头", ""
    prnxml.InsertPNode "任务", "表体", ""
    prnxml.InsertPNode "任务", "表尾", ""
    prnxml.InsertPNode "任务", "页脚", "用友软件"
    
    ReDim AttrName(0, 4)
    ReDim AttrValue(4)
    
'    '插入表头,表尾数据
'    For i = 0 To UBound(AttrName)
'        AttrName(i, 0) = "名字"
'    Next
'    '插入表头,表尾数据
'    AttrName(0, 1) = "单位名称"
'    AttrName(1, 1) = "日期"
'    AttrName(2, 1) = "评价区间"
'    AttrName(3, 1) = "实际得分"
'    AttrName(4, 1) = "信用等级"
'
'    AttrValue(0) = Trim(TxtunitName.Text)
'    AttrValue(1) = CStr(Format(TxtestDate.Text, "YYYY-MM-DD"))
'    AttrValue(2) = CStr(Format(TxtperStart.Text, "YYYY-MM-DD")) & "" & CStr(Format(TxtperEnd.Text, "YYYY-MM-DD"))
'    AttrValue(3) = Trim(TxtrealMark.Text)
'    AttrValue(4) = Trim(TxtcreClass.Text)
'
'    prnxml.InsertHeadNodes "表头", "字段", AttrName, AttrValue
'    ReDim AttrName(1, 1)
'    ReDim AttrValue(1)
'    For i = 0 To UBound(AttrName)
'        AttrName(i, 0) = "名字"
'    Next
'
'    AttrName(0, 1) = "操作员"
'    AttrName(1, 1) = "操作日期"
'
'    AttrValue(0) = Trim(TxtcUsername.Text)
'    AttrValue(1) = CStr(Format(CDate(Trim(TxtOprDate.Text)), "YYYY-MM-DD"))
'    prnxml.InsertHeadNodes "表尾", "字段", AttrName, AttrValue
    
    '插入表体头数据
    ReDim AttrName(2, 1)
    ReDim AttrValue(2)
    For i = 0 To 2
        AttrName(i, 0) = "单元"
    Next
    AttrValue(0) = "信用等级"
    AttrValue(1) = "得分区间"
    AttrValue(2) = "贷款额度"
    
    prnxml.InsertBodyNodes "表体", "表体头", AttrName, AttrValue
    For i = 0 To 2
        AttrValue(i) = ""
    Next
    'prndata creData
    With SuperGrid1
    For i = 0 To .Rows - 2
    '插入表体行数据
        AttrValue(0) = Trim(.TextMatrix(i + 1, 0))
        If i < .Rows - 2 Then
            AttrValue(1) = Trim(.TextMatrix(i + 1, 1)) & " 至 " & Trim(.TextMatrix(i + 1, 2))
        Else
            AttrValue(1) = Trim(.TextMatrix(i + 1, 1)) & "及以上"
        End If
        AttrValue(2) = Trim(.TextMatrix(i + 1, 3))
        prnxml.InsertBodyNodes "表体", "表体行", AttrName, AttrValue
    Next
    End With
    '保存数据文件
    prnxml.saveFile "tcreClassData.xml"
    If initStyleXml Then
        If prnDataBind Then
            xmlInit = True
        Else
            xmlInit = False
        End If
    Else
        xmlInit = False
    End If
    Set prnxml = Nothing
    Exit Sub
error0:
    MsgBox "打印数据准备失败！" & vbCrLf & Err.Description, vbInformation, "错误信息"
'    If rs.State = adStateOpen Then
'        rs.Close
'    End If
    xmlInit = False
    Set prnxml = Nothing
End Sub

Private Function prnDataBind() As Boolean
    Dim lRet As Long
    Dim sData As String
    Dim sStyle As String
    Dim sModuleId As String
    
    sData = App.Path & "\tcreClassData.xml"
    sStyle = App.Path & "\tcreClassStyle.xml"
    sModuleId = "default"