mdlcreditem.bas

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

Attribute VB_Name = "mdlCredItem"
'软件著作权：北京用友软件集团股份有限公司
'  系统名称：信用评价
'  功能说明：信用评价结构定义
'      作者：罗涛
'      时间：2002-05-15
Option Explicit
Dim creData() As String
'查询条件
Public cre_Where As String
Public credstat As Credstate_Stru
Public Type Credstate_Stru
    proctype As String    '目前处理种类
                          'jlzb,
                          'jlmx,
                          'xypj
                          'dked
    ItemName As String    '评价指标名称
    ModifyState As Byte   '0:查询；1：新增；2：修改；3：增行；4：删行
    modified As Boolean
    ItemType As Byte      '0：定量；1：定性
    Dxzbsm As Integer     '定性指标条数
    DxzbDelCount As Integer '已删除定性指标条数
    dlzbitem(2) As Variant    '定量指标数组
    dxzbitem(9, 2) As Variant '定性指标数组
    Memo As String
    selcol As Integer
    selRow As Integer     '当前用户鼠标的位置
        
End Type
'根键常数
Public Const HKEY_CLASSES_ROOT = -2147483648#
Public Const HKEY_CURRENT_USER = -2147483647#
Public Const HKEY_LOCAL_MACHINE = -2147483646#
Public Const HKEY_USERS = -2147483645#

    '键值类型
Public Const REG_SZ = 1&    '字符串值
Public Const REG_BINARY = 3&    '二进制值
Public Const REG_DWORD = 4&    'DWORD 值

    '声明有关API函数
    Public Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, ByRef phkResult As Long) As Long   '建立一个新的主键

    Public Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, ByRef phkResult As Long) As Long   '打开一个主键

    Public Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long   '删除一个主键

    Public Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long   '关闭一个主键

    Public Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByVal lpData As Any, ByVal cbData As Long) As Long   '创建或改变一个键值,lpData应由缺省的ByRef型改为ByVal型

    Public Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, ByRef lpType As Long, ByVal lpData As Any, ByRef lpcbData As Long) As Long   '查询一个键值,lpData应由缺省的ByRef型改为ByVal型

    Public Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long   '删除一个键值


'清除设置
Public Sub clear()
    'credstat As Credstate_Stru
    Dim i As Integer
    credstat.proctype = ""
    credstat.ItemName = ""
    credstat.ModifyState = 0
    credstat.modified = False
    credstat.ItemType = 1
    credstat.Dxzbsm = 0
    credstat.DxzbDelCount = 0
    credstat.Memo = ""
    credstat.selcol = 0
    credstat.selRow = 0
    For i = 0 To 2
        credstat.dlzbitem(i) = ""
    Next
    For i = 0 To 9
        credstat.dxzbitem(i, 0) = ""
        credstat.dxzbitem(i, 1) = ""
        credstat.dxzbitem(i, 2) = ""
    Next
End Sub
'组合定性指标的序号
Public Function combDxID(ByVal quaID As Integer) As String
    If quaID < 10 Then
        combDxID = CStr("0" & quaID)
    Else
        combDxID = CStr(quaID)
    End If
End Function


'分解定性指标的序号
Public Function parseDxID(ByVal xh As String) As Integer
    If left(Trim(xh), 1) = 0 Then
        parseDxID = CInt(right(Trim(xh), 1))
    Else
        parseDxID = CInt(Trim(xh))
    End If
End Function
'在删除后，更新定性指标序号
Public Sub RefreshArray(credstat As Credstate_Stru, sg As SuperGrid)
    Dim i As Long, j As Long
    '此处为删除操作未修改credstat.Dxzbsm时的情况，若已修改则不减1
    For i = credstat.selRow To credstat.Dxzbsm - 1
        For j = 0 To 2
            credstat.dxzbitem(i, j) = credstat.dxzbitem(i + 1, j)
        Next
    Next
End Sub



'同步定性指标到数组
Public Sub copyDxzbToarray(credstat As Credstate_Stru)
    Dim con As New ADODB.Connection
    Dim rs As New ADODB.Recordset
    Dim j As Integer
    Dim sqlstr As String
    'Con.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"

    sqlstr = "select Standard,quaMark,memo From FD_creEvaPara Where itemName=" & "'" & credstat.ItemName & "'" _
                & "order by itemid;"
    con.ConnectionString = zjLogInfo.UfDbName
    'Con.Open zjLogInfo.UfDbName
    con.Open
    rs.Open sqlstr, con, adOpenDynamic
    'rs.MoveFirst
    j = 0
    If Not (rs.EOF Or rs.BOF) Then
        credstat.Memo = IIf(IsNull(rs("memo")), "", rs("memo"))
    Else
        credstat.Memo = ""
    End If
    While Not rs.EOF Or rs.BOF
        credstat.dxzbitem(j, 0) = j + 1
        credstat.dxzbitem(j, 1) = IIf(IsNull(rs("Standard")), "", rs("standard"))
        credstat.dxzbitem(j, 2) = IIf(IsNull(rs("quaMark")), "", rs("quaMark"))
        rs.MoveNext
        j = j + 1
    Wend
    credstat.Dxzbsm = j
    rs.Close
    con.Close
    Set rs = Nothing
    Set con = Nothing
End Sub
'利用数组填充网格
Public Sub LoadArrayToGrid(credstat As Credstate_Stru, sg As SuperGrid)
    Dim i As Integer
    sg.Cols = 3
    sg.Rows = credstat.Dxzbsm + 1
    sg.TextMatrix(0, 0) = "序号"
    sg.TextMatrix(0, 1) = "标准"
    sg.TextMatrix(0, 2) = "得分"
    
    For i = 1 To credstat.Dxzbsm
        sg.TextMatrix(i, 0) = combDxID(CInt(credstat.dxzbitem(i - 1, 0)))
        sg.TextMatrix(i, 1) = CStr(credstat.dxzbitem(i - 1, 1))
        sg.TextMatrix(i, 2) = CStr(credstat.dxzbitem(i - 1, 2))
    Next
End Sub
'检测输入是否是数字
Public Function isnumber(ByVal str As String) As Boolean
    Dim i, j, k As Integer
    Dim numberstr As String
    str = Trim(str)
    i = Len(str)
    If i = 0 Then
        isnumber = False
    Else
        For j = 1 To i
            numberstr = mID(str, j, 1)
            If (Asc(numberstr) >= 48 And Asc(numberstr) <= 57) Then
                isnumber = True
            Else
                If Asc(numberstr) = 46 Then
                    If k <> 0 Then
                        isnumber = False
                    Else
                        isnumber = True
                        k = k + 1
                    End If
                Else
                    isnumber = False
                    Exit Function
                End If
            End If
        Next
    End If
End Function
'用于检查EDIT控件的日期是否合法
'第二个参数用于是否需要错误提示
Public Function DateCheck(cDateExp As Variant, Optional IsShowErrorMsg As Boolean) As String
    Dim date1 As String, date2 As String, dat As String
    Dim l As Integer, m As Integer
    Dim cOperater As String
    dat = Trim(cDateExp)
    m = Len(dat)
    If dat = "" Then
        DateCheck = ""
        If IsShowErrorMsg Then MsgBox "日期不能为空!", vbCritical
        Exit Function
    Else
        Do While l <> -1
            If InStr(dat, ".") Then
                cOperater = "."
                l = InStr(dat, cOperater)
                If l > 0 Then
                    date1 = mID(dat, 1, l - 1)
                    date2 = mID(dat, l + 1)
                    dat = date1 & "/" & date2
                End If
            Else
                l = -1
            End If
        Loop
    End If
    If IsDate(dat) Then
        DateCheck = Format(dat, "YYYY/MM/DD")
    Else
        DateCheck = ""
        If IsShowErrorMsg Then MsgBox "日期非法!", vbCritical
    End If
End Function

Public Function checkDuplicate(ByRef itemid() As String)
    Dim i As Integer
    Dim j As Integer
    Err.clear
    On Error Resume Next
    i = UBound(itemid)
    If Err.Number <> 0 Then
        checkDuplicate = False
        Exit Function
    End If
    
    For i = 0 To UBound(itemid)
        For j = i + 1 To UBound(itemid)
            If (itemid(i) = itemid(j)) Then
                checkDuplicate = False
                Exit Function
            End If
        Next
    Next
    checkDuplicate = True
End Function