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

    Set rs1 = Nothing
    Set rs = Nothing
    'Con.CommitTrans
    Exit Function
error0: loadData = False
    'Con.RollbackTrans
    rs.Close
    Set rs1 = Nothing
    Set rs = Nothing
End Function
'填充supergrid
Private Sub fillsgrid()
    Dim i As Integer
    TxtunitName.Text = GridData(0, 0)
    TxtestDate.Text = GridData(0, 1)
    TxtperStart.Text = GridData(0, 2)
    TxtperEnd.Text = GridData(0, 3)
    TxtrealMark.Text = Format(GridData(0, 4), "#0.00")
    TxtcreClass.Text = GridData(0, 5)
    
'    With SuperGrid1
'    .Rows = UBound(GridData) + 2
'    .Cols = 9
'        For i = 1 To .Rows - 1
'            .TextMatrix(i, 0) = UnitItem("i" & GridData(i - 1, 6))
'            .TextMatrix(i, 1) = IIf(GridData(i - 1, 7), "定量指标", "定性指标")
'            .TextMatrix(i, 2) = GridData(i - 1, 8)
'            If GridData(i - 1, 7) Then
'                .TextMatrix(i, 3) = IIf(GridData(i - 1, 9) = "", "", Format(GridData(i - 1, 9), "#0.0000"))
'            Else
'                .TextMatrix(i, 3) = GridData(i - 1, 9)
'            End If
'            .TextMatrix(i, 4) = IIf(GridData(i - 1, 10) = "", "", Format(GridData(i - 1, 10), "#0.00"))
'            .TextMatrix(i, 5) = Format(GridData(i - 1, 11), "#0.00")
'            .TextMatrix(i, 6) = GridData(i - 1, 12)
'            .TextMatrix(i, 7) = IIf(GridData(i - 1, 13) = "", "", Format(GridData(i - 1, 13), "#0.00"))
'            .TextMatrix(i, 8) = GridData(i - 1, 14)
'        Next
'    End With
    
    Dim j As Integer
    Dim k As Integer
    Dim m As Integer
    Dim item_id() As String
    Dim arrayID() As Integer
    
    On Error Resume Next
    
    ReDim arrayID(UBound(GridData))
    
'    i = UBound(itemOrder)
'    If Err.Number <> 0 Then
    If Not checkDuplicate(itemOrder) Then
        With SuperGrid1
        .Rows = UBound(GridData) + 2
        .Cols = 9
            For i = 1 To .Rows - 1
                .TextMatrix(i, 0) = UnitItem("i" & GridData(i - 1, 6))
                .TextMatrix(i, 1) = IIf(GridData(i - 1, 7), "定量指标", "定性指标")
                .TextMatrix(i, 2) = GridData(i - 1, 8)
                If GridData(i - 1, 7) Then
                    .TextMatrix(i, 3) = IIf(GridData(i - 1, 9) = "", "", Format(GridData(i - 1, 9), "#0.0000"))
                Else
                    .TextMatrix(i, 3) = GridData(i - 1, 9)
                End If
                .TextMatrix(i, 4) = IIf(GridData(i - 1, 10) = "", "", Format(GridData(i - 1, 10), "#0.00"))
                .TextMatrix(i, 5) = Format(GridData(i - 1, 11), "#0.00")
                .TextMatrix(i, 6) = GridData(i - 1, 12)
                .TextMatrix(i, 7) = IIf(GridData(i - 1, 13) = "", "", Format(GridData(i - 1, 13), "#0.00"))
                .TextMatrix(i, 8) = GridData(i - 1, 14)
                arrayID(i - 1) = i - 1
            Next
        End With
        Exit Sub
    End If
    ReDim item_id(UBound(GridData), 1)
    k = 1
    
    With SuperGrid1
    .Rows = UBound(GridData) + 2
    .Cols = 9
    
    For i = 0 To UBound(itemOrder)
       For j = 0 To UBound(GridData)
            If itemOrder(i) = GridData(j, 6) Then
                item_id(i, 0) = GridData(j, 6)
                item_id(i, 1) = j
'                For m = 0 To 7
'                    SuperGrid1.TextMatrix(k, m) = creData(j, m)
'                Next
                arrayID(k - 1) = j
                .TextMatrix(k, 0) = UnitItem("i" & GridData(j, 6))
                .TextMatrix(k, 1) = IIf(GridData(j, 7), "定量指标", "定性指标")
                .TextMatrix(k, 2) = GridData(j, 8)
                If GridData(j, 7) Then
                    .TextMatrix(k, 3) = IIf(GridData(j, 9) = "", "", Format(GridData(j, 9), "#0.0000"))
                Else
                    .TextMatrix(k, 3) = GridData(j, 9)
                End If
                .TextMatrix(k, 4) = IIf(GridData(j, 10) = "", "", Format(GridData(j, 10), "#0.00"))
                .TextMatrix(k, 5) = Format(GridData(j, 11), "#0.00")
                .TextMatrix(k, 6) = GridData(j, 12)
                .TextMatrix(k, 7) = IIf(GridData(j, 13) = "", "", Format(GridData(j, 13), "#0.00"))
                .TextMatrix(k, 8) = GridData(j, 14)
                
                k = k + 1
                Exit For
            End If
        Next
    Next
    
    Dim n As Integer
    n = -1
    
    If k = UBound(GridData) + 2 Then GoTo proc1
    
    Dim bfind As Boolean
loop1:
    bfind = False
    For i = 0 To UBound(GridData)
        bfind = False
        m = -1
        n = -1
        For j = 0 To UBound(GridData)
            If item_id(j, 1) <> i Then
                bfind = True
                If item_id(j, 1) = "" Then
                    m = i
                    n = j
                End If
            Else
                bfind = False
                m = -1
                n = -1
                Exit For
            End If
        Next
        If bfind And m <> -1 And n <> -1 Then
            item_id(n, 0) = GridData(m, 8)
            item_id(n, 1) = m
                arrayID(k - 1) = m
                .TextMatrix(k, 0) = UnitItem("i" & GridData(m, 6))
                .TextMatrix(k, 1) = IIf(GridData(m, 7), "定量指标", "定性指标")
                .TextMatrix(k, 2) = GridData(m, 8)
                If GridData(m, 7) Then
                    .TextMatrix(k, 3) = IIf(GridData(m, 9) = "", "", Format(GridData(m, 9), "#0.0000"))
                Else
                    .TextMatrix(k, 3) = GridData(m, 9)
                End If
                .TextMatrix(k, 4) = IIf(GridData(m, 10) = "", "", Format(GridData(m, 10), "#0.00"))
                .TextMatrix(k, 5) = Format(GridData(m, 11), "#0.00")
                .TextMatrix(k, 6) = GridData(m, 12)
                .TextMatrix(k, 7) = IIf(GridData(m, 13) = "", "", Format(GridData(m, 13), "#0.00"))
                .TextMatrix(k, 8) = GridData(m, 14)

            k = k + 1
            If k = UBound(GridData) + 2 Then GoTo proc1
            GoTo loop1
            End If
    Next
'    Dim n As Integer
'    n = -1
'    If k = UBound(GridData) + 2 Then GoTo proc1
'    Dim bfind As Boolean
'    For i = 0 To UBound(GridData)
'         n = -1
'         m = -1
'         bfind = False
'         For j = 0 To UBound(item_id)
'             If item_id(j) <> "" Then
'                 If GridData(i, 6) = item_id(j) Then
'                     bfind = True
'                     Exit For
'                 Else
'                     bfind = False
'                     m = j
'                     n = i
'                 End If
'             Else
'                 bfind = False
'                 m = j
'                 n = i
'                 Exit For
'             End If
'         Next
'         If m <> -1 And n <> -1 And Not bfind Then item_id(j) = GridData(i, 6)
'         If Not bfind And n <> -1 Then
''             For m = 0 To 7
''                 SuperGrid1.TextMatrix(k, m) = GridData(n, m)
''             Next
'                arrayID(k - 1) = n
'                .TextMatrix(k, 0) = UnitItem("i" & GridData(n, 6))
'                .TextMatrix(k, 1) = IIf(GridData(n, 7), "定量指标", "定性指标")
'                .TextMatrix(k, 2) = GridData(n, 8)
'                If GridData(j, 7) Then
'                    .TextMatrix(k, 3) = IIf(GridData(n, 9) = "", "", Format(GridData(n, 9), "#0.0000"))
'                Else
'                    .TextMatrix(k, 3) = GridData(n, 9)
'                End If
'                .TextMatrix(k, 4) = IIf(GridData(n, 10) = "", "", Format(GridData(n, 10), "#0.00"))
'                .TextMatrix(k, 5) = Format(GridData(n, 11), "#0.00")
'                .TextMatrix(k, 6) = GridData(n, 12)
'                .TextMatrix(k, 7) = IIf(GridData(n, 13) = "", "", Format(GridData(n, 13), "#0.00"))
'                .TextMatrix(k, 8) = GridData(n, 14)
'
'             k = k + 1
'         End If
'     Next
'    End With
proc1:
    Dim gridcolone() As Variant
    i = UBound(GridData, 1)
    j = UBound(GridData, 2)
    ReDim gridcolone(i, j)
    For i = 0 To UBound(GridData)
        j = arrayID(i)
        For k = 0 To UBound(GridData, 2)
            gridcolone(i, k) = GridData(j, k)
        Next
    Next

'***************************************************
    For i = 0 To UBound(GridData)
        For j = 0 To UBound(GridData, 2)
            Debug.Print i & "/" & j & "=" & GridData(i, j) & "----" & gridcolone(i, j)
        Next
    Next
'****************************************************

    For i = 0 To UBound(GridData)
        For j = 0 To UBound(GridData, 2)
            GridData(i, j) = gridcolone(i, j)
        Next
    Next

    Erase gridcolone
End With
End Sub
'设置查询界面状态
Private Sub setQueryState(ByVal curCursor As Integer)
    SuperGrid1.ReadOnly = True
    credstat.ModifyState = 0
    credstat.modified = False
    
    TxtunitName.Enabled = False
    CmdUnitNameRef.Enabled = False
    CmdUnitNameRef.Visible = False
    
    TxtestDate.Enabled = False
    CmdEstDateRef.Enabled = False
    CmdEstDateRef.Visible = False
    
    TxtperStart.Enabled = False
    cmdperStartRef.Enabled = False
    cmdperStartRef.Visible = False
    
    TxtperEnd.Enabled = False
    CmdperEndRef.Enabled = False
    CmdperEndRef.Visible = False
    
    With tlbTool
        .Buttons("print").Enabled = True
        .Buttons("preview").Enabled = True
        .Buttons("Output").Enabled = True
        .Buttons("search").Enabled = True
        If curCursor <> 0 Then
            .Buttons("firstEnt").Enabled = True
            .Buttons("prevEnt").Enabled = True
        Else
            .Buttons("firstEnt").Enabled = False
            .Buttons("prevEnt").Enabled = False
        End If
        'If curCursor <> credstat.Dxzbsm - 1 And credstat.Dxzbsm <> 0 Then
        'UBound(cUnitCode) Then
        If curCursor <> entId.count - 1 And entId.count <> 1 Then
            .Buttons("nextEnt").Enabled = True
            .Buttons("LastEnt").Enabled = True
        Else
            .Buttons("nextEnt").Enabled = False
            .Buttons("LastEnt").Enabled = False
        End If
        'If credstat.Dxzbsm = 1 Then
        If entId.count = 1 Then
            .Buttons("nextEnt").Enabled = False
            .Buttons("LastEnt").Enabled = False
            .Buttons("nextEnt").Enabled = False
            .Buttons("LastEnt").Enabled = False
        End If
        .Buttons("Estamate").Enabled = True
        .Buttons("Modi").Enabled = True
        .Buttons("Cancel").Enabled = False
        .Buttons("Save").Enabled = False
        .Buttons("Help").Enabled = True
        .Buttons("Exit").Enabled = True
    End With
    ocxCtbTool.RefreshEnable
End Sub
'修改数据过程
Private Sub ModiProc()
    credstat.ModifyState = 2
    credstat.modified = True
    duplicate = False
    Call setModiState
End Sub
'评价数据过程
Private Sub estamateProc()
'    Call loadZeroData
    Dim i As Long
    TxtrealMark.Text = 0#
    TxtcreClass.Text = ""
    With SuperGrid1
        For i = 1 To .Rows - 1
            .TextMatrix(i, 3) = ""
            .TextMatrix(i, 7) = ""
        Next
    End With
    credstat.ModifyState = 1
    credstat.modified = True
    Call setModiState
End Sub
'查询数据过程
Private Sub queryproc()
    Dim i As Integer
    Dim rs As New ADODB.Recordset
'    Dlgquerystr.Visible = True
'    Dlgquerystr.Enabled = True
    Dlgquerystr.Show 1
    DoEvents
    If cre_Where = "" Then
        cre_Where = "1=1"
    End If
    sqlstr = "select cUnitName,cUnitcode From fd_AccUnit where " & cre_Where & ";"
    rs.Open sqlstr, con, adOpenDynamic, adLockOptimistic
    If rs.RecordCount = 0 Then
        MsgBox "没有找到符合条件的单位！", vbInformation, "系统信息"
    Else
        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
        curCursor = 0
        If preLoadData(0) Then
            Call fillsgrid
            Call setQueryState(0)
        Else
            MsgBox "数据初始化失败！", vbInformation, "错误信息"
        End If
    End If
'    sqlstr = "select distinct b.cunitname As cunitname,a.cunitcode as cunitcode from FD_creEstamate a,FD_AccUnit b Where "
'    sqlstr = sqlstr & " a.cunitcode=b.cunitcode and  "
'    sqlstr = sqlstr & cre_Where
'    rs.Open sqlstr, Con, adOpenDynamic