regmod.bas

一个功能强大、程序条理分明的学生学籍管理系统

    End Select
    
    '关闭键
    RegCloseKey hKey
End Sub

'******************************************************************
'功能：枚举注册表中给定主键下的键名
'输入：
'   plKey                   Long        根键名
'   psKey                   String      主键名
'   输出:    Enumkeys       String      字符串数组
'说明： 仅仅支持 DWORD, SZ, 和 BINARY value 这三种类型.
'******************************************************************
Function EnumKeys(ByVal plKey As Long, ByVal psKey As String) As String()
    Dim hKey As Long, Index As Long, length As Long
    ReDim Result(0 To 100) As String
    Dim FileTimeBuffer(100) As Byte
    
    If Len(psKey) Then
        If RegOpenKeyEx(plKey, psKey, 0, KEY_READ, hKey) Then Exit Function
        plKey = hKey
    End If
    
    For Index = 0 To 999999
        ' 为数组预设空间
        If Index > UBound(Result) Then
            ReDim Preserve Result(Index + 99) As String
        End If
        length = 260                   ' 键名的最大长度
        Result(Index) = Space$(length)
        If RegEnumKey(hKey, Index, Result(Index), length) Then Exit For
        Result(Index) = Left$(Result(Index), InStr(Result(Index), vbNullChar) - 1)
    Next
   
    If hKey Then RegCloseKey hKey
        
    ' 把数组中多余没有用到的空间释放
    ReDim Preserve Result(Index - 1) As String
    EnumKeys = Result()
End Function

'******************************************************************
'功能：枚举注册表中给定主键下的键名和键值
'输入：
'   plKey                   Long        根键名
'   psKey                   String      主键名
'   输出:    Enumkeys       Variant     变体型二维串数组
'                          第一维存放键名，第二维存放键值
'说明： 仅仅支持 DWORD, SZ, 和 BINARY value 这三种类型.
'******************************************************************
Function EnumValues(ByVal plKey As Long, ByVal psKey As String) As Variant()
    Dim hKey As Long, Index As Long, valueType As Long
    Dim name As String, nameLen As Long
    Dim lngValue As Long, strValue As String, dataLen As Long
    
    ReDim Result(0 To 1, 0 To 100) As Variant

    If Len(psKey) Then
        If RegOpenKeyEx(plKey, psKey, 0, KEY_READ, hKey) Then Exit Function
        plKey = hKey
    End If
    
    For Index = 0 To 999999
        ' 开辟数组空间
        If Index > UBound(Result, 2) Then
            ReDim Preserve Result(0 To 1, Index + 99) As Variant
        End If
        nameLen = 260                   ' 键名最大长度
        name = Space$(nameLen)
        dataLen = 4096
        ReDim binValue(0 To dataLen - 1) As Byte
        If RegEnumValue(hKey, Index, name, nameLen, ByVal 0&, valueType, _
            binValue(0), dataLen) Then Exit For
        Result(0, Index) = Left$(name, nameLen)
        
        Select Case valueType
            Case REG_DWORD
                ' 将最初的4字节内容复制到一个long变量中
                CopyMemory lngValue, binValue(0), 4
                Result(1, Index) = lngValue '该long变量即为键值
            Case REG_SZ
                '将结果转换为合适的字符串形式
                Result(1, Index) = Left$(StrConv(binValue(), vbUnicode), dataLen - 1)
            Case Else
                ' 别的所有情况，均按Byte型数组来存放
                ReDim Preserve binValue(0 To dataLen - 1) As Byte
                Result(1, Index) = binValue()
        End Select
    Next
   
    If hKey Then RegCloseKey hKey
        
    ' 释放多余的数组空间
    ReDim Preserve Result(0 To 1, Index - 1) As Variant
    EnumValues = Result()
End Function


'另外一些实现枚举的函数写法
Public Function EnumerateValues(ByVal plKey As Long, ByVal psKey As String, _
    ByRef sKeyNames() As Variant) As Long
    
        
    Dim lResult As Long
    Dim hKey As Long
    Dim sName As String
    Dim lNameSize As Long
    Dim lIndex As Long
    Dim dataLen As Long
 
    'iKeyCount = 0
    Erase sKeyNames()
    
    lIndex = 0
    lResult = RegOpenKeyEx(plKey, psKey, 0, KEY_QUERY_VALUE, hKey)
    
    If (lResult = ERROR_SUCCESS) Then
        Do While lResult = ERROR_SUCCESS
        
            'Set buffer space
            lNameSize = 260 'cNameMax + 1
            sName = Space$(lNameSize)
            If (lNameSize = 0) Then lNameSize = 1
            dataLen = 4096
            
            lResult = RegEnumValue(hKey, lIndex, sName, lNameSize, _
                0&, 0&, 0&, dataLen)
            ' Log "RegEnumValue returned:" & lResult
            If (lResult = ERROR_SUCCESS) Then
            
                ' Although in theory you can also retrieve the actual
                ' value and type here, I found it always (ultimately) resulted in
                ' a GPF, on Win95 and NT. Why? Can anyone help?
                
                sName = Left$(sName, lNameSize)
                ' Log "Enumerated value:" & sName
            
                lIndex = lIndex + 1
                ReDim Preserve sKeyNames(1 To lIndex) As Variant
                sKeyNames(lIndex) = sName
            End If
        Loop
        If lIndex > 0 Then
            EnumerateValues = 0
        Else
            EnumerateValues = lResult
        End If
    Else
        EnumerateValues = lResult
    End If
    
    If (hKey <> 0) Then
        RegCloseKey hKey
    End If
    
    ' Log "Exit Enumerate Values"

End Function

Public Function EnumerateSections(ByVal plKey As Long, ByVal psKey As String, _
    sSect() As String, ByRef iSectCount As Long) As Boolean
    
    Dim lResult As Long
    Dim hKey As Long
    Dim dwReserved As Long
    Dim szBuffer As String
    Dim lBuffSize As Long
    Dim lIndex As Long
    Dim lType As Long
    Dim sCompKey As String
    Dim iPos As Long
    
    iSectCount = 0
    Erase sSect()
    '
    lIndex = 0
    
    lResult = RegOpenKeyEx(plKey, psKey, 0, &H8, hKey)
    Do While lResult = ERROR_SUCCESS
        'Set buffer space
        szBuffer = String$(255, 0)
        lBuffSize = Len(szBuffer)
        
        'Get next value
        lResult = RegEnumKey(hKey, lIndex, szBuffer, lBuffSize)
        
    If (lResult = ERROR_SUCCESS) Then
        iSectCount = iSectCount + 1
        ReDim Preserve sSect(1 To iSectCount) As String
        iPos = InStr(szBuffer, Chr$(0))
        If (iPos > 0) Then
            sSect(iSectCount) = Left(szBuffer, iPos - 1)
        Else
            sSect(iSectCount) = Left(szBuffer, lBuffSize)
        End If
    End If
    
    lIndex = lIndex + 1
    Loop
    
    If (hKey <> 0) Then
        RegCloseKey hKey
    End If
    
    If iSectCount > 0 Then
        EnumerateSections = True
    Else
        EnumerateSections = False
    End If
    Exit Function
    
End Function

Function secEnumValue(ByVal plKey As Long, ByVal psKey As String) As Variant()
    
    Dim hKey As Long, iIndex As Long, lResult As Long
    Dim name As String, nameLen As Long
    Dim dataLen As Long
    ReDim Result(0 To 100) As Variant

    ' Open the key, exit if not found.
    lResult = RegOpenKeyEx(plKey, psKey, 0, KEY_READ, hKey)
    
    iIndex = 0
        
    Do While lResult = ERROR_SUCCESS
        nameLen = 260                   ' Max length for a key name.
        name = Space$(nameLen)
        dataLen = 4096
        lResult = RegEnumValue(hKey, iIndex, name, nameLen, 0&, 0&, _
            0&, 4096)
        If lResult = ERROR_SUCCESS Then
            name = Left$(name, nameLen)
            ReDim Preserve Result(0 To iIndex) As Variant
            Result(iIndex) = name
            iIndex = iIndex + 1
        End If
    Loop
   
    ' Close the key, if it was actually opened.
    If hKey Then RegCloseKey hKey
        
    secEnumValue = Result()
End Function

Function sngEnumValue(ByVal plKey As Long, ByVal psKey As String, _
    ByVal Index As Long) As String
    
    Dim hKey As Long, lResult As Long
    Dim sName As String, nameLen As Long
    Dim dataLen As Long

    ' Open the key, exit if not found.
    lResult = RegOpenKeyEx(plKey, psKey, 0, KEY_READ, hKey)
        
    nameLen = 260                   ' Max length for a key name.
    sName = Space$(nameLen)
    dataLen = 4096
    
    If lResult = ERROR_SUCCESS Then
        lResult = RegEnumValue(hKey, Index, sName, nameLen, 0&, 0&, _
            0&, dataLen)
        If lResult = ERROR_SUCCESS Then
            sName = Left$(sName, nameLen)
        End If
        sngEnumValue = sName
    Else
        sngEnumValue = vbNullString
    End If
    
    ' Close the key, if it was actually opened.
    If hKey Then RegCloseKey hKey
        
End Function