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

Dim UnitItem As New Collection
'公司代码和名称集合，公司代码为key
Dim Entprise As New Collection
Dim entId As New Collection
'已评价单位代码
Dim cUnitCode() As String
'选中的指标代码
Dim itemID() As String
'实际得分变量
Dim sum_Realmark As Double
Dim sqlstr As String
'信用等级数组
Dim creClass() As Variant
'数据数组
Dim GridData() As Variant
'定义当前游标
Dim curCursor As Integer
'定义重复窗口标志
Dim duplicate As Boolean
Dim creclassstr As String
Dim canExit As Boolean
Dim xmlInit As Boolean
    
Dim itemOrder() As String
Dim edit_error As Boolean
Dim error_num As Integer
Dim appendnew As Boolean
Dim delold As Boolean

'定义系统共用信息
Private Sub definepara()
    Dim rs As New ADODB.Recordset
    Dim i, j, k As Integer
    '判断用户是否建立了信用指标
    sqlstr = "select distinct itemname from FD_creEvaPara where selflag='1' order by itemName"
    rs.Open sqlstr, con, adOpenDynamic
    If rs.RecordCount <> 0 Then
        ReDim itemID(rs.RecordCount - 1)
    Else
        MsgBox "您还没有建立信用评价模型或已修改了信用指标且未更新信用评价模型定义！" & vbCrLf & "请先建立或更新信用评价模型！", vbCritical, "系统错误"
        canExit = True
        SuperGrid1.ReadOnly = True
        Exit Sub
    End If
    rs.Close
    '将当前指标信息存入集合UnitItem和itemID数组中
'    Sqlstr = "select distinct itemname,itemID from FD_creEvaPara where selflag=1 order by itemName"
    sqlstr = "select distinct itemname,Min(itemId) as itemID from FD_creEvaPara where selflag='1' group by itemname order by itemname"
    rs.Open sqlstr, con, adOpenDynamic
    i = 0
    '重置UnitItem集合
    If UnitItem.count <> 0 Then
        For i = 1 To UnitItem.count
            UnitItem.Remove 1
        Next
    End If
    '向集合和数组中添加元素
    i = 0
    While Not (rs.EOF Or rs.BOF)
        If i <> 0 Then
            If UnitItem("i" & itemID(i - 1)) <> rs("itemName") Then
                UnitItem.Add CStr(rs("itemName")), "i" & CStr(rs("itemID"))
                itemID(i) = CStr(rs("itemID"))
                i = i + 1
                rs.MoveNext
            Else
                rs.MoveNext
            End If
        Else
            UnitItem.Add CStr(rs("itemName")), "i" & CStr(rs("itemID"))
            itemID(i) = CStr(rs("itemID"))
            i = i + 1
            rs.MoveNext
        End If
    Wend
    rs.Close
    '将当前单位信息存入集合Entprise和entID中
    sqlstr = "select cUnitCode,cUnitName from FD_AccUnit order by cUnitCode"
    rs.Open sqlstr, con, adOpenDynamic
    If Entprise.count <> 0 Then
        For i = 1 To Entprise.count
            Entprise.Remove 1
        Next
    End If
    If entId.count <> 0 Then
        For i = 1 To entId.count
            entId.Remove 1
        Next
    End If
    i = 0
    While Not (rs.EOF Or rs.BOF)
        Entprise.Add CStr(rs("cUnitName")), "e" & CStr(rs("cUnitCode"))
        entId.Add CStr(rs("cUnitCode")), "i" & i
        rs.MoveNext
        i = i + 1
    Wend
    i = 0
    rs.Close
    '将信用等级信息存入creClass数组中
    sqlstr = "select lowmark,creclass from Fd_creClass order by lowMark"
    rs.Open sqlstr, con, adOpenDynamic
    If rs.RecordCount <> 0 Then
        ReDim creClass(rs.RecordCount - 1, 1)
        i = 0
        While Not (rs.EOF Or rs.BOF)
           creClass(i, 0) = rs("lowMark")
           creClass(i, 1) = rs("creClass")
           i = i + 1
           rs.MoveNext
        Wend
    Else
        ReDim creClass(0, 1)
        creClass(0, 0) = "#$"
        creClass(0, 1) = "#$"
    End If
    rs.Close
    '将单位代码存入cunitcode数组中
    sqlstr = "select distinct cunitcode from FD_creEstamate order by cUnitCode"
    rs.Open sqlstr, con, adOpenDynamic
    If rs.RecordCount > 0 Then
        ReDim cUnitCode(rs.RecordCount - 1)
        credstat.Dxzbsm = rs.RecordCount
        i = 0
        While Not (rs.EOF Or rs.BOF)
            cUnitCode(i) = rs("cunitcode")
            i = i + 1
            rs.MoveNext
        Wend
    Else
        credstat.Dxzbsm = 0
    End If
    rs.Close
    'Set rs = Nothing
End Sub
'装载空表
Private Sub loadZeroData()
    Dim rs As New ADODB.Recordset
    Dim rs1 As New ADODB.Recordset
    Dim i, j, k As Integer
    On Error Resume Next
    i = UBound(itemID)
    If Err.Number <> 0 Then
        i = 2
    Else
        i = UBound(itemID) + 2
    End If
'    If IsArray(itemID) Then
'        i = UBound(itemID) + 2
'    Else
'        i = 2
'    End If
    If i = 2 Then
        ReDim GridData(0, 15)
    Else
        ReDim GridData(UBound(itemID), 15)
    End If
    sqlstr = "select * from FD_creEvaPara where selFlag=1 order by itemID,itemName,itemType Desc"
    rs.Open sqlstr, con, adOpenDynamic
    i = 0
    sum_Realmark = 0
    While Not (rs.EOF Or rs.BOF)
        
        TxtUnitCode.Text = Trim(entId(curCursor + 1))
        GridData(i, 0) = Entprise("e" & entId(curCursor + 1))
        GridData(i, 1) = ""
        GridData(i, 2) = ""
        GridData(i, 3) = ""
        GridData(i, 4) = 0
        GridData(i, 5) = ""
        GridData(i, 6) = rs("itemId")
        GridData(i, 7) = rs("itemType")
        If rs("itemType") Then
            GridData(i, 8) = IIf(IsNull(rs("calFormu")), "", rs("calFormu"))
            GridData(i, 12) = IIf(IsNull(rs("calMarkFormu")), "", rs("calMarkFormu"))
            GridData(i, 10) = IIf(IsNull(rs("stanvalue")), "", rs("stanValue"))
            GridData(i, 11) = IIf(IsNull(rs("stanMark")), "", rs("stanMark"))
            GridData(i, 14) = rs("memo")
            GridData(i, 15) = rs("calMarkFormu1")
        Else
            sqlstr = "select standard,quaMark from Fd_creEvaPara where itemname='" & rs("itemName") & "' order by quaMark desc"
            rs1.Open sqlstr, con, adOpenDynamic
            If rs1.RecordCount <> 0 Then
                rs1.MoveFirst
            End If
            j = 1
            GridData(i, 8) = ""
            GridData(i, 12) = ""
            GridData(i, 14) = rs("memo")
            While Not rs1.EOF Or rs1.BOF
                GridData(i, 8) = GridData(i, 8) & "0" & j & "," & rs1("standard") & ";"
                GridData(i, 12) = GridData(i, 12) & "0" & j & "," & rs1("quaMark") & ";"
                j = j + 1
                GridData(i, 11) = IIf(IsNull(rs("stanMark")), "", rs("stanMark"))
                rs1.MoveNext
                rs.MoveNext
            Wend
            rs1.Close
            GridData(i, 10) = ""
            GridData(i, 15) = ""
        End If
        GridData(i, 9) = ""
        GridData(i, 13) = ""
        i = i + 1
        If GridData(i - 1, 7) Then
            rs.MoveNext
        End If
    Wend
    
    TxtunitName.Text = GridData(0, 0)

    With SuperGrid1
        .Rows = i + 1
        For i = 1 To .Rows - 1
            .TextMatrix(i, 0) = CStr(UnitItem(CStr("i" & GridData(i - 1, 6))))
            .TextMatrix(i, 1) = IIf(GridData(i - 1, 7), "定量指标", "定性指标")
            .TextMatrix(i, 2) = GridData(i - 1, 8)
            .TextMatrix(i, 3) = GridData(i - 1, 9)
            .TextMatrix(i, 4) = GridData(i - 1, 10)
            .TextMatrix(i, 5) = GridData(i - 1, 11)
            .TextMatrix(i, 6) = GridData(i - 1, 12)
            .TextMatrix(i, 7) = GridData(i - 1, 13)
            .TextMatrix(i, 8) = GridData(i - 1, 14)
        Next
    End With
    credstat.ModifyState = 1
    Call setModiState
End Sub
'设置修改状态
Private Sub setModiState()
    credstat.modified = True
    SuperGrid1.ReadOnly = True
    TxtunitName.Enabled = True
    CmdUnitNameRef.Enabled = True
    TxtestDate.Enabled = True
    CmdEstDateRef.Enabled = True
    TxtperStart.Enabled = True
    cmdperStartRef.Enabled = True
    TxtperEnd.Enabled = True
    CmdperEndRef.Enabled = True
    With tlbTool
        .Buttons("print").Enabled = False
        .Buttons("preview").Enabled = False
        .Buttons("Output").Enabled = False
        .Buttons("search").Enabled = False
        .Buttons("firstEnt").Enabled = False
        .Buttons("prevEnt").Enabled = False
        .Buttons("nextEnt").Enabled = False
        .Buttons("LastEnt").Enabled = False
        .Buttons("Estamate").Enabled = False
        .Buttons("Modi").Enabled = False
        .Buttons("Cancel").Enabled = True
        .Buttons("Save").Enabled = True
        .Buttons("Help").Enabled = True
        .Buttons("Exit").Enabled = True
    End With
    ocxCtbTool.RefreshEnable
End Sub
'装载数据到后台数组中
Private Function loadData(ByVal cUnitCode As String) As Boolean
   Dim i As Integer, j As Integer
   Dim rs As New ADODB.Recordset
   Dim rs1 As New ADODB.Recordset
   On Error GoTo error0
   'rs.Close
   sum_Realmark = 0
   sqlstr = "select distinct a.itemname As itemName,a.itemId as itemid,a.itemType as itemtype ,a.calFormu as calformu,a.stanValue as stanvalue ,"
   sqlstr = sqlstr & "a.stanMark As stanMark ,a.calmarkFormu As calMarkFormu,a.calmarkFormu1 as calMarkFormu1 ,"
   sqlstr = sqlstr & "a.Standard As Standard,a.quaMark As quaMark,"
   sqlstr = sqlstr & "b.cUnitCode As cUnitCode,b.estDate As estDate,b.perStart as perStart,b.perEnd As perEnd,"
   sqlstr = sqlstr & "b.creClass As creClass,b.realvalue As realvalue,b.realmark As realMark,a.memo As Memo "
   sqlstr = sqlstr & " from FD_creEvaPara a,FD_creEstamate b "
   sqlstr = sqlstr & "where b.cunitCode='" & cUnitCode & "' and a.itemId=b.itemId order by cUnitCode,b.itemID"
   rs.Open sqlstr, con, adOpenDynamic, adLockOptimistic
   ReDim GridData(UBound(itemID), 15)
   '把数据装载入后台数组
   i = 0
   While Not (rs.EOF Or rs.BOF)
        GridData(i, 0) = Entprise("e" & rs("cUnitCode"))
        TxtUnitCode.Text = Trim(rs("cUnitCode"))
        GridData(i, 1) = IIf(IsNull(rs("estDate")), "", Format(rs("estdate"), "YYYY-MM-DD"))
        GridData(i, 2) = IIf(IsNull(rs("perStart")), "", Format(rs("perstart"), "YYYY-MM-DD"))
        GridData(i, 3) = IIf(IsNull(rs("perEnd")), "", Format(rs("perstart"), "YYYY-MM-DD"))
        GridData(i, 4) = IIf(IsNull(rs("realMark")), "", Format(rs("realmark"), "#0.00"))
        GridData(i, 5) = IIf(IsNull(rs("creClass")), "", rs("creClass"))
        GridData(i, 6) = rs("itemID")
        GridData(i, 7) = rs("itemType")
        If rs("itemType") Then
            GridData(i, 8) = rs("calFormu")
            GridData(i, 12) = rs("calMarkFormu")
            GridData(i, 10) = rs("stanValue")
            GridData(i, 15) = rs("calmarkformu1")
        Else
           sqlstr = "select standard,quaMark from Fd_creEvaPara where itemName='" & rs("itemName") & "' order by quaMark desc"
           rs1.Open sqlstr, con, adOpenDynamic
            If rs1.RecordCount <> 0 Then
                rs1.MoveFirst
            End If
            j = 1
           GridData(i, 8) = ""
           GridData(i, 12) = ""
           While Not (rs1.EOF Or rs1.BOF)
                GridData(i, 8) = GridData(i, 8) & "0" & j & "," & rs1("standard") & ";"
                GridData(i, 12) = GridData(i, 12) & "0" & j & "," & rs1("quaMark") & ";"
                j = j + 1
                rs1.MoveNext
                'rs.MoveNext
           Wend
            rs1.Close
            'GridData(i, 10) = rs("stanvalue")
            GridData(i, 10) = ""
            GridData(i, 15) = ""
        End If
        If IsNull(rs("realValue")) Then
            GridData(i, 9) = ""
        Else
            GridData(i, 9) = rs("realValue")
        End If
        If IsNull(rs("stanMark")) Then
            GridData(i, 11) = ""
        Else
            GridData(i, 11) = rs("stanMark")
        End If
        
        'GridData(i, 13) = IIf(IsNull(rs("realMark")), "", rs("realmark"))
        GridData(i, 14) = IIf(IsNull(rs("memo")), "", rs("memo"))
        If GridData(i, 9) = "" Then
            GridData(i, 13) = ""
        Else
            If GridData(i, 7) Then
                GridData(i, 13) = calrealmark(i)
            Else
                GridData(i, 13) = IIf(IsNull(rs("realMark")), "", rs("realmark"))
            End If
        End If
        If GridData(i, 13) <> "" Then
            sum_Realmark = sum_Realmark + GridData(i, 13)
        End If
        i = i + 1
        'If GridData(i - 1, 7) Then
            rs.MoveNext
        'End If
    Wend
    loadData = True
    j = 0
    For i = 0 To UBound(creClass) - 1
        If sum_Realmark > creClass(i, 0) And sum_Realmark < creClass(i + 1, 0) Then
            creclassstr = creClass(i, 1)
            Exit For
        End If
        j = j + 1
    Next
    If j = UBound(creClass) Then
        creclassstr = creClass(j, 1)
    End If
    'Con.BeginTrans
    
    If creclassstr <> GridData(0, 5) Then
        sqlstr = "update Fd_creEstamate set creclass='" & creclassstr & "' where cunitcode='" & cUnitCode & "'"
        con.Execute sqlstr
'        MsgBox "该单位的评价信息已发审改变！" & vbCrLf & "请察看该单位信息！", vbInformation, "信息提示"
    End If
    'Con.CommitTrans
    For i = 0 To UBound(GridData)
        GridData(i, 4) = sum_Realmark
        GridData(i, 5) = creclassstr
    Next
    rs.Close