评价模型.frm

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

        .Buttons("Help").ToolTipText = "F1"

        .Buttons("Exit").Image = "Exit"
        .Buttons("Exit").Caption = "退出"
        .Buttons("Exit").ToolTipText = "Ctrl+F4"

     End With

End Sub

Private Function show_creClass() As Boolean
    Dim result As VbMsgBoxResult
    show_creClass = False
    If credstat.modified Then
        result = MsgBox("您还有数据未保存，是否决定在退出信用评价程序前保存数据？", vbYesNoCancel, "退出程序")
        Select Case result
         Case vbYes
             If SaveData Then
                show_creClass = True
                credstat.ModifyState = 0
                credstat.modified = False
             Else
                show_creClass = False
                Exit Function
             End If
        Case vbNo
                show_creClass = True
                credstat.ModifyState = 0
                credstat.modified = False
        Case vbCancel
                show_creClass = False
                Exit Function
        End Select
    Else
        show_creClass = True
    End If
End Function


Private Function getUserSettings() As String
        Dim nKeyHandle As Long, nValueType As Long, nLength As Long
        Dim sValue As String
        Dim i As Long
        Dim j As Long
        Dim k As Long
        
        sValue = ""
        
        Call RegCreateKey(HKEY_CURRENT_USER, "U8Soft\Fd_ZJGL\fd_creEstModal", nKeyHandle)
        
        sValue = Space(255)
        nLength = 255
        
        Call RegQueryValueEx(nKeyHandle, "orderstring", 0, nValueType, sValue, nLength)
        If Trim(sValue) = "" Then
            getUserSettings = ""
            Exit Function
        Else
            i = InStr(sValue, "E")
            If i > 1 Then
                getUserSettings = mID(Trim(sValue), 1, i - 1)
            Else
                getUserSettings = ""
            End If
        End If
        
        sValue = Space(255)
        nLength = 255
        
        Call RegQueryValueEx(nKeyHandle, "widthstring", 0, nValueType, sValue, nLength)
        
        i = InStr(sValue, "E")
        If i > 0 Then sValue = mID(sValue, 1, i - 1)
        If Trim(sValue) = "" Then
            colwidth(0) = -10
        Else
            i = InStr(sValue, "/")
            j = 0
            k = 1
            
            Do While i <> 0
                colwidth(j) = CDbl(mID(sValue, k, i - k))
                k = i + 1
                i = InStr(k, sValue, "/")
                j = j + 1
            Loop
        End If
        
        Call RegDeleteValue(nKeyHandle, "orderstring")
        Call RegDeleteValue(nKeyHandle, "widthstring")
        Call RegDeleteKey(HKEY_CURRENT_USER, "U8Soft\Fd_ZJGL\fd_creEstModal")
        Call RegCloseKey(nKeyHandle)
End Function

Private Sub setUserSettings()
         Dim nKeyHandle As Long, nValueType As Long, nLength As Long
         Dim sValue As String
         Dim wValue As String
         Dim i As Long
         Dim j As Integer
         Dim k As Integer
         sValue = ""
         wValue = ""
         k = 0
         For i = 1 To SuperGrid1.Rows - 1
           For j = 0 To UBound(creData)
               If SuperGrid1.TextMatrix(i, 1) = creData(j, 1) Then
                   k = k + 1
                   If k < SuperGrid1.Rows - 1 Then
                       sValue = sValue & CStr(creData(i - 1, 8)) & "/"
                   Else
                       sValue = sValue & CStr(creData(i - 1, 8)) & "/E"
                   End If
                   Exit For
               End If
           Next
        Next
        For i = 0 To SuperGrid1.Cols - 1
           wValue = wValue & CStr(SuperGrid1.colwidth(i)) & "/"
        Next
        wValue = wValue & "E"
        
        Call RegCreateKey(HKEY_CURRENT_USER, "U8Soft\Fd_ZJGL\fd_creEstModal", nKeyHandle)
        Call RegSetValueEx(nKeyHandle, "orderstring", 0, REG_SZ, sValue, 255)
        Call RegSetValueEx(nKeyHandle, "widthstring", 0, REG_SZ, wValue, 255)
        '      sValue = Space(255)
        '      nLength = 255
              
        '      Call RegDeleteValue(nKeyHandle, "My Value")
        '      Call RegDeleteKey(HKEY_CURRENT_USER, "New Registry Key")
        Call RegCloseKey(nKeyHandle)

End Sub


Private Sub getOrderString()
    Dim i As Integer
    Dim j As Integer
    Dim k As Integer
    Dim os As String
    
    os = getUserSettings()
    i = InStr(1, os, "/")
    j = 0
    k = 1
    
    Do While i <> 0
        ReDim Preserve itemOrder(j)
        itemOrder(j) = mID(os, k, i - k)
        k = i + 1
        i = InStr(k, os, "/")
        j = j + 1
    Loop
       
End Sub

Private Sub fillGrid()
    Dim i As Integer
    Dim j As Integer
    Dim k As Integer
    Dim m As Integer
    Dim item_id() As String
    On Error Resume Next
    
'    i = UBound(itemOrder)
'    If Err.Number <> 0 Then
    If Not checkDuplicate(itemOrder) Then
        For i = 1 To UBound(creData) + 1
            For j = 0 To 7
               SuperGrid1.TextMatrix(i, j) = creData(i - 1, j)
            Next
        Next
        Exit Sub
    End If
    ReDim queryOrder(UBound(creData))
    ReDim item_id(UBound(creData), 1)
    k = 1
    For i = 0 To UBound(itemOrder)
       For j = 0 To UBound(creData)
            If itemOrder(i) = creData(j, 8) Then
                item_id(i, 0) = creData(j, 8)
                item_id(i, 1) = j
                queryOrder(k - 1) = creData(j, 8)
                For m = 0 To 7
                    SuperGrid1.TextMatrix(k, m) = creData(j, m)
                Next
                k = k + 1
                Exit For
            End If
        Next
    Next
    
    Dim n As Integer
    n = -1
    
    If k = UBound(creData) + 2 Then GoTo proc1
    
    Dim bfind As Boolean
loop1:
    bfind = False
    For i = 0 To UBound(creData)
        bfind = False
        m = -1
        n = -1
        For j = 0 To UBound(creData)
            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) = creData(m, 8)
            item_id(n, 1) = m
            queryOrder(k - 1) = creData(m, 8)
            For j = 0 To 7
                 SuperGrid1.TextMatrix(k, j) = creData(m, j)
            Next
            k = k + 1
            If k = UBound(creData) + 2 Then GoTo proc1
            GoTo loop1
            End If
    Next

'    For i = 0 To UBound(creData)
'         n = -1
'         m = -1
'         bfind = False
'         For j = 0 To UBound(item_id)
'             If item_id(j) <> "" Then
'                 If creData(i, 8) = 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
'            Dim l As Long
'            For l = 0 To UBound(creData)
'                If itemOrder(m) = creData(l, 8) Then
'                    n = l
'                    Exit For
'                Else
'                    n = -1
'                End If
'            Next
'        End If
'         If m <> -1 And n <> -1 And Not bfind Then
'            item_id(m, 0) = creData(n, 8)
'        End If
'         If m <> -1 And n <> -1 Then
'            item_id(m, 1) = n
'             For m = 0 To 7
'                 SuperGrid1.TextMatrix(k, m) = creData(n, m)
'             Next
'             k = k + 1
'         End If
'     Next
'
'     If k = UBound(creData) + 2 Then GoTo proc1
'     For i = 0 To UBound(creData)
'        m = -1
'        n = -1
'        For j = 0 To UBound(item_id)
'            If item_id(j, 1) <> i Then
'                m = i
'                If item_id(j, 1) = "" Then
'                    n = j
'                End If
'            Else
'                m = -1
'                Exit For
'            End If
'        Next
'        If m <> -1 And n <> -1 Then
'            item_id(n, 1) = m
'            For l = 0 To 7
'                SuperGrid1.TextMatrix(k, l) = creData(k, l)
'            Next
'            k = k + 1
'            If k = UBound(creData) + 2 Then Exit For
'        End If
'    Next
    
    
proc1:
    For j = 1 To SuperGrid1.Rows - 1
        For i = 0 To 8
            If i = 8 Then
                'creData(j - 1, 8) = item_id(j - 1, 0)
                creData(j - 1, 8) = queryOrder(j - 1)
            Else
                creData(j - 1, i) = SuperGrid1.TextMatrix(j, i)
            End If
        Next
    Next
End Sub

Private Function checkRealValue() As Boolean
    Dim rs As New ADODB.Recordset
    Dim i As Integer
    Dim j As Long
    Dim str As String
    Dim sqlstr As String
    
    i = 0
    j = 0
    str = ""
    
    With SuperGrid1
        For j = 1 To SuperGrid1.Rows - 1
            If .TextMatrix(j, 2) = "定量指标" Then
                str = Trim(.TextMatrix(j, 6))
                i = InStr(1, str, "实际值")
                While i <> 0
                    str = left(str, i - 1) & "2234567890123456" & right(str, Len(str) - (i + 2))
                    i = InStr(1, str, "实际值")
                Wend
            
                i = InStr(1, str, "标准值")
                While i <> 0
                    str = left(str, i - 1) & Trim(.TextMatrix(j, 4)) & right(str, Len(str) - (i + 2))
                    i = InStr(1, str, "标准值")
                Wend
            
                i = InStr(1, str, "标准分")
                While i <> 0
                    str = left(str, i - 1) & Trim(.TextMatrix(j, 5)) & right(str, Len(str) - (i + 2))
                    i = InStr(1, str, "标准分")
                Wend
                
                On Error GoTo error0
                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
                rs.Close
            End If
        Next
    End With
    checkRealValue = True
    Set rs = Nothing