浏览器

开发平台：
Visual Basic

Registry.bas：源码内容
							Attribute VB_Name = "mdlRegistry"
'***********************By 陈锐******************************
'这是一个操作注册表的Bas文件,其中包含可以建立新键值,删除
'键值,查询键值的函数.
'Web Site: http://www.nease.net/~blackcat
'EMail: blackcat@nease.net
Option Explicit
Public Const REG_SZ As Long = 1
Public Const REG_DWORD As Long = 4
Public Const HKEY_CLASSES_ROOT = &H80000000
Public Const HKEY_CURRENT_USER = &H80000001
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public Const HKEY_USERS = &H80000003
Public Const ERROR_NONE = 0
Public Const ERROR_BADDB = 1
Public Const ERROR_BADKEY = 2
Public Const ERROR_CANTOPEN = 3
Public Const ERROR_CANTREAD = 4
Public Const ERROR_CANTWRITE = 5
Public Const ERROR_OUTOFMEMORY = 6
Public Const ERROR_INVALID_PARAMETER = 7
Public Const ERROR_ACCESS_DENIED = 8
Public Const ERROR_INVALID_PARAMETERS = 87
Public Const ERROR_NO_MORE_ITEMS = 259
Public Const ERROR_SUCCESS As Long = 0&
Public Const KEY_ALL_ACCESS = &H3F
Public Const REG_OPTION_NON_VOLATILE = 0
Public Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
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 RegCreateKeyEx Lib "advapi32.dll" Alias "RegCreateKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal Reserved As Long, ByVal lpClass As String, ByVal dwOptions As Long, ByVal samDesired As Long, ByVal lpSecurityAttributes As Long, phkResult As Long, lpdwDisposition 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 RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Public Declare Function RegQueryValueExString Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, ByVal lpData As String, lpcbData As Long) As Long
Public Declare Function RegQueryValueExLong Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Long, lpcbData As Long) As Long
Public Declare Function RegQueryValueExNULL Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, ByVal lpData As Long, lpcbData As Long) As Long
Public Declare Function RegSetValueExString Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByVal lpValue As String, ByVal cbData As Long) As Long
Public Declare Function RegSetValueExLong Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpValue As Long, ByVal cbData As Long) As Long
Public Declare Function RegDeleteKey& Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String)
Public Declare Function RegDeleteValue& Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String)
Public Declare Function RegEnumValue Lib "advapi32.dll" Alias "RegEnumValueA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpValueName As String, ByRef lpcbValueName As Long, ByVal lpReserved As Long, ByRef lpType As Long, ByRef lpData As Byte, ByRef lpcbData As Long) As Long
Public Declare Function SHDeleteKey Lib "shlwapi.dll" Alias "SHDeleteKeyA" (ByVal hKey As Long, ByVal pszSubKey As String) As Long
'Public Function DeleteKey(lPredefinedKey As Long, sKeyName As String)
'    Dim lRetVal As Long
'    Dim hKey As Long
'
'    lRetVal = RegOpenKeyEx(lPredefinedKey, sKeyName, 0, KEY_ALL_ACCESS, hKey)
'    lRetVal = RegDeleteKey(lPredefinedKey, sKeyName)
'    RegCloseKey (hKey)
'End Function
'
'Public Function DeleteValue(lPredefinedKey As Long, sKeyName As String, sValueName As String)
'       Dim lRetVal As Long
'       Dim hKey As Long
'
'       lRetVal = RegOpenKeyEx(lPredefinedKey, sKeyName, 0, KEY_ALL_ACCESS, hKey)
'       lRetVal = RegDeleteValue(hKey, sValueName)
'       RegCloseKey (hKey)
'End Function
'
'Public Function SetValueEx(ByVal hKey As Long, sValueName As String, lType As Long, vValue As Variant) As Long
'    Dim lValue As Long
'    Dim sValue As String
'
'    Select Case lType
'        Case REG_SZ
'            sValue = vValue
'            SetValueEx = RegSetValueExString(hKey, sValueName, 0&, lType, sValue, Len(sValue))
'        Case REG_DWORD
'            lValue = vValue
'            SetValueEx = RegSetValueExLong(hKey, sValueName, 0&, lType, lValue, 4)
'        End Select
'
'End Function
'
Function QueryValueEx(ByVal lhKey As Long, ByVal szValueName As String, vValue As Variant) As Long
    Dim cch As Long
    Dim lrc As Long
    Dim lType As Long
    Dim lValue As Long
    Dim sValue As String
    On Error GoTo QueryValueExError
    lrc = RegQueryValueExNULL(lhKey, szValueName, 0&, lType, 0&, cch)
    If lrc <> ERROR_NONE Then Error 5
    Select Case lType
        Case REG_SZ:
            sValue = String(cch, 0)
            lrc = RegQueryValueExString(lhKey, szValueName, 0&, lType, sValue, cch)
            If lrc = ERROR_NONE Then
                vValue = Left$(sValue, cch)
            Else
                vValue = Empty
            End If
        Case REG_DWORD:
            lrc = RegQueryValueExLong(lhKey, szValueName, 0&, lType, lValue, cch)
            If lrc = ERROR_NONE Then vValue = lValue
        Case Else
            lrc = -1
    End Select
QueryValueExExit:
    QueryValueEx = lrc
    Exit Function
QueryValueExError:
    Resume QueryValueExExit
End Function
'Public Function CreateNewKey(lPredefinedKey As Long, sNewKeyName As String)
'    Dim hNewKey As Long
'    Dim lRetVal As Long
'
'    lRetVal = RegCreateKeyEx(lPredefinedKey, sNewKeyName, 0&, vbNullString, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, 0&, hNewKey, lRetVal)
'    RegCloseKey (hNewKey)
'End Function
'
''Sub Main()
''    '函数在注册表的"HKEY_CURRENT_USERSoftware"中建立了
''    '一个SubKey1项并在其中建立了值，并在显示后删除建立
''    '的值，如果你想通过RegEdit看到结果，可以将最后两句
''    '删除，不过要记得手动删除建立的键值
''    CreateNewKey HKEY_CURRENT_USER, "SoftwareSubKey1SubKey2"
''    SetKeyValue HKEY_CURRENT_USER, "SoftwareSubKey1SubKey2", "Test", "1000", REG_DWORD
''    MsgBox QueryValue(HKEY_CURRENT_USER, "SoftwareSubKey1SubKey2", "Test")
''    'DeleteValue HKEY_CURRENT_USER, "SoftwareSubKey1SubKey2", "Test"
'''    DeleteKey HKEY_CURRENT_USER, "SoftwareSubKey1SubKey2"
'''    DeleteKey HKEY_CURRENT_USER, "SoftwareSubKey1"
''    SHDeleteKey HKEY_CURRENT_USER, "SoftwareSubKey1"
''End Sub
'
'
'Public Function SetKeyValue(lPredefinedKey As Long, sKeyName As String, sValueName As String, vValueSetting As Variant, lValueType As Long)
'       Dim lRetVal As Long
'       Dim hKey As Long
'
'       lRetVal = RegOpenKeyEx(lPredefinedKey, sKeyName, 0, KEY_ALL_ACCESS, hKey)
'       lRetVal = SetValueEx(hKey, sValueName, lValueType, vValueSetting)
'       RegCloseKey (hKey)
'
'End Function
Public Function QueryValue(lPredefinedKey As Long, sKeyName As String, sValueName As String)
       Dim lRetVal As Long
       Dim hKey As Long
       Dim vValue As Variant
       lRetVal = RegOpenKeyEx(lPredefinedKey, sKeyName, 0, KEY_ALL_ACCESS, hKey)
       lRetVal = QueryValueEx(hKey, sValueName, vValue)
       QueryValue = vValue
       RegCloseKey (hKey)
End Function
'---------------------------------------------------------------------------------------
' Procedure : EnumValue
' DateTime  : 2005-4-15 19:00
' Author    : Lingll
' Purpose   :
'---------------------------------------------------------------------------------------
Public Sub EnumRegValue(lPredefinedKey&, sKeyName$, _
        coName As Collection, coType As Collection)
Dim hKey&, i&
Dim tName$, tcName&, tType&
If coName Is Nothing Then
    Set coName = New Collection
End If
If coType Is Nothing Then
    Set coType = New Collection
End If
If RegOpenKeyEx(lPredefinedKey, sKeyName, 0, KEY_ALL_ACCESS, hKey) = 0 Then
    tName = String(MAX_PATH + 1, vbNullChar)
    i = 0
    tcName = MAX_PATH + 1
    While RegEnumValue(hKey, i, tName, tcName, 0, tType, ByVal 0&, ByVal 0&) = 0
        coName.Add Left$(tName, tcName)
        coType.Add tType
        i = i + 1
        tcName = MAX_PATH + 1
    Wend
End If
End Sub

						