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

                    If CDbl(SuperGrid1.TextMatrix(SuperGrid1.row, 3)) < 0 Then
                        duplicate = True
                        MsgBox "实际值不允许为负数", vbInformation, "输入错误"
                        edit_error = True
                        'Exit Sub
                    End If
                        Call calmark
                    'End If
                Else
                    Call calmark
                End If
            End If
        End If
    End If
        SuperGrid1.ProtectUnload
        error_num = 0
End Sub

Private Sub SuperGrid1_RowColChange()
    
    If edit_error Then
        SuperGrid1.row = credstat.selrow
        SuperGrid1.col = credstat.selcol
        If error_num = 0 Then
            error_num = 2
            Beep
            MsgBox "实际值输入错误！", vbInformation, "输入错误"
        ElseIf error_num = 1 Then
            error_num = error_num + 1
        ElseIf error_num = 2 Then
            error_num = 0
        End If
        SuperGrid1.SetFocus
        Exit Sub
    End If
    
    If credstat.ModifyState <> 0 Then
    '    Debug.Print "before rowclochange" & SuperGrid1.row & " " & SuperGrid1.col & " " & SuperGrid1.TextMatrix(SuperGrid1.row, 0)
        If (SuperGrid1.col <> 3) And SuperGrid1.row <> 0 Then
            SuperGrid1.ReadOnly = True
        Else
            SuperGrid1.ReadOnly = False
        End If
        If SuperGrid1.TextMatrix(SuperGrid1.row, 1) = "定性指标" And SuperGrid1.col = 3 Then
            SuperGrid1.SetColProperty 3, 12, UserBrowButton, EditNormal
        Else
            SuperGrid1.SetColProperty 3, 12, DblBrowButton, EditDbl, 4
        End If
    End If
    credstat.selrow = SuperGrid1.row
    credstat.selcol = SuperGrid1.col
    '    Debug.Print "rowclochange" & SuperGrid1.row & " " & SuperGrid1.col & " " & SuperGrid1.TextMatrix(SuperGrid1.row, 0)
    '    Debug.Print "after rowclochange" & credstat.selRow & " " & credstat.selcol & " " & SuperGrid1.TextMatrix(SuperGrid1.row, 0)
    
End Sub

Private Sub showcombo()
' Combo1.Top = SuperGrid1.CellTop
' Combo1.Left = SuperGrid1.CellLeft
' Combo1.Height = SuperGrid1.CellHeight
' Combo1.Width = SuperGrid1.CellWidth
' Combo1.clear
    Dim rs1 As New ADODB.Recordset
    Dim rfd As New UFReferC.UFReferClient
    rfd.SetLogin zjLogInfo
    rfd.SetReferSQLString "select standard As 标准,quaMark As 得分 from  FD_creEvaPara where itemName='" & _
            SuperGrid1.TextMatrix(SuperGrid1.row, 0) & "'   order by quaMark desc;"
    rfd.SetReferDisplayMode enuGrid
    rfd.Show
    If rfd.recmx Is Nothing Then Exit Sub
    Set rs1 = rfd.recmx
    SuperGrid1.TextMatrix(SuperGrid1.row, 3) = rs1(0)
    SuperGrid1.TextMatrix(SuperGrid1.row, 7) = rs1(1)
End Sub

'Private Sub SuperGrid1_UpdateData(ByVal IsNew As Boolean, ByVal R As Long, Buffer() As String)
'    If credstat.selcol = 3 Then
'        Call calmark
'    End If
'
'End Sub

Private Sub calmark()
    Dim rs As New ADODB.Recordset
    Dim i As Integer
    Dim j As Integer
    Dim str As String
    
    Debug.Print SuperGrid1.TextMatrix(credstat.selrow, 7)
    Debug.Print sum_Realmark
    With SuperGrid1
        'Con.BeginTrans
        If Trim(.TextMatrix(credstat.selrow, 1)) = "定量指标" Then
'            Sqlstr = "select * from FD_tmpValue "
'            rs.Open Sqlstr, Con, adOpenDynamic, adLockOptimistic
'            rs.AddNew
'            rs("realValue") = .TextMatrix(credstat.selRow, 3)
'            rs("stanValue") = .TextMatrix(credstat.selRow, 4)
'            rs("stanMark") = .TextMatrix(credstat.selRow, 5)
'            rs.Update
'            rs.Close
'            Sqlstr = "select " & GridData(credstat.selRow - 1, 15) & " from FD_tmpValue"
'            Sqlstr = Sqlstr & " where realvalue=" & .TextMatrix(credstat.selRow, 3)
'            rs.Open Sqlstr, Con, adOpenDynamic
'            If .TextMatrix(credstat.selRow, 7) <> "" Then
'                sum_Realmark = sum_Realmark - .TextMatrix(credstat.selRow, 7) + rs(0)
'            Else
'                sum_Realmark = sum_Realmark + rs(0)
'            End If
'            .TextMatrix(credstat.selRow, 7) = rs(0)
'            rs.Close
'            Sqlstr = "DELETE From Fd_tmpValue;"
'            Con.Execute Sqlstr
'            ' Con.Execute "delete from FD_tmpValue ;"
'            'Con.CommitTrans
        
            str = Trim(GridData(credstat.selrow - 1, 12))
            'STR = Trim(TxtcalMarkFormu.Text)
            i = InStr(1, str, "实际值")
            If CDbl(.TextMatrix(credstat.selrow, 3)) < 0 Then GoTo error0
            While i <> 0
                'str = left(str, i - 1) & Format(.TextMatrix(credstat.selRow, 3), "#0.0000") & right(str, Len(str) - (i + 2))
                'str = left(str, i - 1) & .TextMatrix(credstat.selRow, 3) & "*1.0000000000" & right(str, Len(str) - (i + 2))
                str = left(str, i - 1) & " convert(float," & .TextMatrix(credstat.selrow, 3) & ") " & right(str, Len(str) - (i + 2))
                i = InStr(1, str, "实际值")
            Wend
            i = InStr(1, str, "标准值")
            While i <> 0
                'str = left(str, i - 1) & Format(.TextMatrix(credstat.selRow, 4), "#0.00") & right(str, Len(str) - (i + 2))
                'str = left(str, i - 1) & GridData(credstat.selRow - 1, 10) & "*1.0000000000" & right(str, Len(str) - (i + 2))
                str = left(str, i - 1) & " convert(float," & GridData(credstat.selrow - 1, 10) & ")" & right(str, Len(str) - (i + 2))
                i = InStr(1, str, "标准值")
            Wend
            i = InStr(1, str, "标准分")
            While i <> 0
                'str = left(str, i - 1) & Format(.TextMatrix(credstat.selRow, 5), "#0.00") & right(str, Len(str) - (i + 2))
                'str = left(str, i - 1) & GridData(credstat.selRow - 1, 11) & "*1.0000000000" & right(str, Len(str) - (i + 2))
                str = left(str, i - 1) & " convert(float," & GridData(credstat.selrow - 1, 11) & ")" & right(str, Len(str) - (i + 2))
                i = InStr(1, str, "标准分")
            Wend
            'str = str & "*1.00000000"
            On Error GoTo error0
            sqlstr = "select count(*), convert(float," & Trim(str) & ")  As tt from fd_tmpvalue"
            'sqlstr = "select count(*), " & Trim(str) & "  As tt from fd_tmpvalue"
            rs.Open sqlstr, con, adOpenDynamic, adLockOptimistic
            
            If rs.RecordCount = 0 Then
                GoTo error0
            End If
             If .TextMatrix(credstat.selrow, 7) <> "" Then
                sum_Realmark = sum_Realmark - .TextMatrix(credstat.selrow, 7) + rs(1)
            Else
                sum_Realmark = sum_Realmark + rs(1)
            End If
            .TextMatrix(credstat.selrow, 7) = Format(rs(1), "#0.00")
           
            rs.Close
     Else
            sqlstr = "select quamark from fd_creEvapara where standard='" & Trim(.TextMatrix(credstat.selrow, 3)) & "' and "
            sqlstr = sqlstr & "itemName='" & Trim(.TextMatrix(credstat.selrow, 0)) & "'"
            On Error GoTo error0
            rs.Open sqlstr, con, adOpenDynamic, adLockOptimistic
            If Not (rs.EOF Or rs.BOF) Then
                If Not IsNull(rs("quamark")) Then
                     If .TextMatrix(credstat.selrow, 7) <> "" Then
                        sum_Realmark = sum_Realmark - .TextMatrix(credstat.selrow, 7) + rs(0)
                    Else
                        sum_Realmark = sum_Realmark + rs(0)
                    End If
                    .TextMatrix(credstat.selrow, 7) = Format(rs("quaMark"), "#0.00")
                Else
                    If error_num = 0 Then
                        MsgBox "实际值输入错误！", vbInformation, "输入错误"
                        error_num = 1
                    End If
                    .SetFocus
                    GoTo error0
                End If
            Else
                If error_num = 0 Then
                    MsgBox "实际值输入错误！", vbInformation, "输入错误"
                End If
                .SetFocus
                GoTo error0
            End If
        End If
            
        TxtrealMark.Text = Format(sum_Realmark, "#0.00")
        'rs.Open "select lowmark,highMark,creClass from Fd_creClass order by lowMark", Con, adOpenDynamic
        
        j = 0
        If creClass(0, 0) <> "#$" And creClass(0, 1) <> "#$" Then
            If sum_Realmark < 0 Then
                'TxtcreClass.Text = creClass(0, 1)
                TxtcreClass.Text = ""
            Else
                For i = 0 To UBound(creClass) - 1
                    If sum_Realmark >= creClass(i, 0) And sum_Realmark < creClass(i + 1, 0) Then
                        TxtcreClass.Text = creClass(i, 1)
                        Exit For
                    End If
                    j = j + 1
                    'rs.MoveNext
                Next
                If j = UBound(creClass) Then
                    TxtcreClass.Text = creClass(j, 1)
                End If
            End If
        Else
            TxtcreClass.Text = ""
        End If
        'rs.Close
        Set rs = Nothing
End With
    
    Debug.Print SuperGrid1.TextMatrix(credstat.selrow, 7)
    Debug.Print sum_Realmark
    error_num = 0
    edit_error = False
Exit Sub
error0:
    
    Debug.Print SuperGrid1.TextMatrix(credstat.selrow, 7)
    Debug.Print sum_Realmark
    
    If SuperGrid1.TextMatrix(credstat.selrow, 7) <> "" Then
        sum_Realmark = sum_Realmark - SuperGrid1.TextMatrix(credstat.selrow, 7)
    End If
    SuperGrid1.TextMatrix(credstat.selrow, 7) = ""
    
    TxtrealMark.Text = Format(sum_Realmark, "#0.00")
    
    Debug.Print SuperGrid1.TextMatrix(credstat.selrow, 7)
    Debug.Print sum_Realmark
    
    j = 0
    If creClass(0, 0) <> "#$" And creClass(0, 1) <> "#$" Then
        If sum_Realmark <= 0 Then
            'TxtcreClass.Text = creClass(0, 1)
            TxtcreClass.Text = ""
            
        Else
            For i = 0 To UBound(creClass) - 1
                If sum_Realmark >= creClass(i, 0) And sum_Realmark < creClass(i + 1, 0) Then
                    TxtcreClass.Text = creClass(i, 1)
                    Exit For
                End If
                j = j + 1
            Next
            If j = UBound(creClass) Then
                TxtcreClass.Text = creClass(j, 1)
            End If
        End If
    Else
        TxtcreClass.Text = ""
    End If
    
    If rs.State = adStateOpen Then
        rs.Close
    End If
    Set rs = Nothing
    error_num = 1
    edit_error = True
    SuperGrid1.SetFocus
    If Err.Number <> 0 Then
        MsgBox Err.Description, vbInformation, "计算错误"
        Err.clear
    End If
End Sub

Private Sub tlbTool_ButtonClick(ByVal Button As MsComctlLib.Button)
    With tlbTool
        Select Case Button.key
            Case "print"
                Call printProc
            Case "preview"
                Call previewProc
            Case "Output"
                Call outputProc
            Case "Modi"
                Call ModiProc
            Case "search"
                Call queryproc
            Case "firstEnt"
                Call firstEntProc
            Case "prevEnt"
                Call prevEntProc
            Case "nextEnt"
                Call nextEntProc
            Case "LastEnt"
                Call lastEntProc
            Case "Estamate"
                Call estamateProc
            Case "Cancel"
                Call CancelProc
            Case "Save"
                Call saveProc
            Case "Help"
                SendKeys "{F1 3}"
            Case "Exit"
                Unload Me
                Exit Sub
        End Select
    End With
    If Button.key <> "Exit" Then
        ocxCtbTool.RefreshEnable
    End If
End Sub
'初始化过程
Private Sub Initialize()
    Dim rs As New ADODB.Recordset
    Dim rs1 As New ADODB.Recordset
    Dim i, j, k As Integer
    Dim existItem As Boolean
    Dim difItem() As String
    
    '调用初始定义函数，定义系统变量
    appendnew = False
    delold = False
    Call definepara
    If entId.count = 0 Or Entprise.count = 0 Then
        canExit = True
    End If
    If canExit Then
        Exit Sub
    End If
    con.BeginTrans
    If Not deleteOldItem Then
        GoTo error0
    End If
'    rs.Open "select count(*) from FD_creEstamate", Con, adOpenDynamic
'    If rs(0) = 0 Then
'        Call loadZeroData
'        rs.Close
'        Exit Sub
'    End If
'    rs.Close
    rs.Open "select Distinct itemid from FD_creEstamate order by itemID", con, adOpenDynamic
    j = rs.RecordCount
    If j > 0 Then
        ReDim difItem(j - 1)
        i = 0
        While Not (rs.EOF Or rs.BOF)
            difItem(i) = rs(0)
            i = i + 1
            rs.MoveNext
        Wend
        rs.Close
        On Error GoTo error0
        
        Dim m_Pos As Integer
        m_Pos = 0
        
        If UBound(itemID) > UBound(difItem) Then
            For i = 0 To UBound(itemID)
                For j = 0 To UBound(difItem)
                    If itemID(i) = difItem(j) Then
                        existItem = False
                        Exit For
                    Else
                        existItem = True
                        m_Pos = i
                        'Exit For
                    End If
                Next
                If existItem Then
                    appendnew = Tr