访问注册表

'This program needs 3 buttons
Const REG_SZ = 1 ' Unicode nul terminated string
Const REG_BINARY = 3 ' Free form binary
Const HKEY_CURRENT_USER = &H80000001
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long
Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long
Function RegQueryStringValue(ByVal hKey As Long, ByVal strValueName As String) As String
    Dim lResult As Long, lValueType As Long, strBuf As String, lDataBufSize As Long
    'retrieve nformation about the key
    lResult = RegQueryValueEx(hKey, strValueName, 0, lValueType, ByVal 0, lDataBufSize)
    If lResult = 0 Then
        If lValueType = REG_SZ Then
            'Create a buffer
            strBuf = String(lDataBufSize, Chr$(0))
            'retrieve the key's content
            lResult = RegQueryValueEx(hKey, strValueName, 0, 0, ByVal strBuf, lDataBufSize)
            If lResult = 0 Then
                'Remove the unnecessary chr$(0)'s
                RegQueryStringValue = Left$(strBuf, InStr(1, strBuf, Chr$(0)) - 1)
            End If
        ElseIf lValueType = REG_BINARY Then
            Dim strData As Integer
            'retrieve the key's value
            lResult = RegQueryValueEx(hKey, strValueName, 0, 0, strData, lDataBufSize)
            If lResult = 0 Then
                RegQueryStringValue = strData
            End If
        End If
    End If
End Function
Function GetString(hKey As Long, strPath As String, strValue As String)
    Dim Ret
    'Open the key
    RegOpenKey hKey, strPath, Ret
    'Get the key's content
    GetString = RegQueryStringValue(Ret, strValue)
    'Close the key
    RegCloseKey Ret
End Function
Sub SaveString(hKey As Long, strPath As String, strValue As String, strData As String)
    Dim Ret
    'Create a new key
    RegCreateKey hKey, strPath, Ret
    'Save a string to the key
    RegSetValueEx Ret, strValue, 0, REG_SZ, ByVal strData, Len(strData)
    'close the key
    RegCloseKey Ret
End Sub
Sub SaveStringLong(hKey As Long, strPath As String, strValue As String, strData As String)
    Dim Ret
    'Create a new key
    RegCreateKey hKey, strPath, Ret
    'Set the key's value
    RegSetValueEx Ret, strValue, 0, REG_BINARY, CByte(strData), 4
    'close the key
    RegCloseKey Ret
End Sub
Sub DelSetting(hKey As Long, strPath As String, strValue As String)
    Dim Ret
    'Create a new key
    RegCreateKey hKey, strPath, Ret
    'Delete the key's value
    RegDeleteValue Ret, strValue
    'close the key
    RegCloseKey Ret
End Sub
Private Sub Command1_Click()
    Dim strString As String
    'Ask for a value
    strString = InputBox("Please enter a value between 0 and 255 to be saved as a binary value in the registry.", App.Title)
    If strString = "" Or Val(strString) > 255 Or Val(strString) < 0 Then
        MsgBox "Invalid value entered ...", vbExclamation + vbOKOnly, App.Title
        Exit Sub
    End If
    'Save the value to the registry
    SaveStringLong HKEY_CURRENT_USER, "KPD-Team", "BinaryValue", CByte(strString)
End Sub
Private Sub Command2_Click()
    'Get a string from the registry
    Ret = GetString(HKEY_CURRENT_USER, "KPD-Team", "BinaryValue")
    If Ret = "" Then MsgBox "No value found !", vbExclamation + vbOKOnly, App.Title: Exit Sub
    MsgBox "The value is " + Ret, vbOKOnly + vbInformation, App.Title
End Sub
Private Sub Command3_Click()
    'Delete the setting from the registry
    DelSetting HKEY_CURRENT_USER, "KPD-Team", "BinaryValue"
    MsgBox "The value was deleted ...", vbInformation + vbOKOnly, App.Title
End Sub
Private Sub Form_Load()
    Command1.Caption = "Set Value"
    Command2.Caption = "Get Value"
    Command3.Caption = "Delete Value"
End Sub

如果可以，我还是用Getsetting和SaveSetting.

用楼上的方法只能修改HKEY_CURRENT_USER下面的键值，我需要修改的是任何一个键值，有什么办法吗？

'Option Explicit'注册表的入口常量
Private Const HKEY_CLASSES_ROOT = &H80000000
Private Const HKEY_CURRENT_USER = &H80000001
Private Const HKEY_LOCAL_MACHINE = &H80000002
Private Const HKEY_USERS = &H80000003'注册表的访问权限常量
Private Const KEY_QUERY_VALUE = &H1
Private Const KEY_SET_VALUE = &H2
Private Const KEY_CREATE_SUB_KEY = &H4
Private Const KEY_ENUMERATE_SUB_KEYS = &H8
Private Const KEY_NOTIFY = &H10
Private Const KEY_CREATE_LINk = &H20
Private Const KEY_ALL_ACCESS = &H3F'打开/建立键值的可选项常量
Private Const REG_OPTION_NON_VOLATILE = 0&
Private Const REG_OPTION_VOLATILE = &H1'建立新键或打开已存在的键常量
Private Const REG_CREATED_NEW_KEY = &H1
Private Const REG_OPENED_EXISTING_KEY = &H2'预先定义的访问注册表的权限常量
Private Const STANDARD_RIGHTS_ALL = &H1F0000
Private Const SPECIFIC_RIGHTS_ALL = &HFFFF'API的返回代码常量
Private Const ERROR_SUCCESS = 0&
Private Const ERROR_ACCESS_DENIED = 5
Private Const ERROR_NO_MORE_ITEMS = 259'返回数值类型常量
Private Const REG_NONE = (0)
Private Const REG_SZ = (1)
Private Const REG_EXPAND_SZ = (2)
Private Const REG_BINARY = (3)
Private Const REG_DWORD = (4)
Private Const REG_DWORD_LITTLE_ENDIAN = (4)
Private Const REG_DWORD_BIG_ENDIAN = (5)
Private Const REG_LINK = (6)
Private Const REG_MULTI_SZ = (7)
Private Const REG_RESOURCE_LIST = (8)
Private Const REG_FULL_RESOURCE_DESCRIPTOR = (9)
Private Const REG_RESOURCE_REQUIREMENTS_LIST = (10)'访问注册表的API函数要用到的结构类型
Private Type SECURITY_ATTRIBUTES
    nLength As Long
    lpSecurityDescriptor As Long
    bInheritHandle As Boolean
End TypePrivate Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End TypePrivate Const REGAGENT_NOKEY = -1002
Private Const REGAGENT_NOSUBKEY = -1003Private 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
Private 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
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long         ' Note that if you declare the lpData parameter as String, you must pass it By Value.
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, ByVal lpData As Any, lpcbData As Long) As Long
Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long
Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long

Public m_lRootKey As Long, m_strKey As String, m_strSubKey As String
Public m_lKeyType As Long, m_lStatus As Long, m_strKeyValue As StringPublic Sub CreateKey()

    Dim lKeyID As Long, lRetVal As Long

    m_lStatus = 0
    If Len(m_strKey) = 0 Then
        m_lStatus = REGAGENT_NOKEY
        Exit Sub
    End If

    m_lStatus = RegCreateKeyEx(m_lRootKey, m_strKey, 0&, vbNullString, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, 0&, lKeyID, lRetVal)

    m_lStatus = RegCloseKey(lKeyID)

End SubPublic Sub DeleteKey()

    Dim lKeyID As Long, lRetVal As Long

    m_lStatus = 0

    If Len(m_strKey) = 0 Then
        m_lStatus = REGAGENT_NOKEY
        Exit Sub
    End If

    If Len(m_strSubKey) = 0 Then
        m_lStatus = REGAGENT_NOSUBKEY
        Exit Sub
    End If

    m_lStatus = RegCreateKeyEx(m_lRootKey, m_strKey, 0&, vbNullString, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, 0&, lKeyID, lRetVal)
    If m_lStatus = 0 Then
        m_lStatus = RegDeleteKey(lKeyID, ByVal m_strSubKey)
    End If

End SubPublic Sub SetValue()

    Dim lKeyID As Long, lRetVal As Long

    m_lStatus = 0

    If Len(m_strKey) = 0 Then
        m_lStatus = REGAGENT_NOKEY
        Exit Sub
    End If

    If Len(m_strSubKey) = 0 Then
        m_lStatus = REGAGENT_NOSUBKEY
        Exit Sub
    End If

    m_lStatus = RegCreateKeyEx(m_lRootKey, m_strKey, 0&, vbNullString, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, 0&, lKeyID, lRetVal)
    If m_lStatus <> 0 Then
        Exit Sub
    End If

    If Len(m_strKeyValue) = 0 Then
        m_lStatus = RegSetValueEx(lKeyID, m_strSubKey, 0&, m_lKeyType, 0&, 0&)
    Else
        m_lStatus = RegSetValueEx(lKeyID, m_strSubKey, 0&, m_lKeyType, ByVal m_strKeyValue, Len(m_strKeyValue) + 1)
    End If

End SubPublic Sub GetValue()

    Dim lKeyID As Long, sBuffer As String, lBufferSize As Long

    On Error Resume Next

    m_lStatus = 0

    If Len(m_strKey) = 0 Then
        m_lStatus = REGAGENT_NOKEY
        Exit Sub
    End If

    If Len(m_strSubKey) = 0 Then
        m_lStatus = REGAGENT_NOSUBKEY
        Exit Sub
    End If

    m_lStatus = RegOpenKeyEx(m_lRootKey, m_strKey, 0&, KEY_QUERY_VALUE, lKeyID) 'open the key
    If m_lStatus <> 0 Then
        Exit Sub
    End If

    sBuffer = Space(255)
    lBufferSize = Len(sBuffer)
    m_lStatus = RegQueryValueEx(lKeyID, m_strSubKey, 0&, m_lKeyType, sBuffer, lBufferSize)
    If lBufferSize < 2 Then
        m_strKeyValue = Empty
        Exit Sub
    End If

    m_strKeyValue = Left$(sBuffer, lBufferSize - 1)


End SubPublic Sub DeleteValue()

    Dim lKeyID As Long

    m_lStatus = 0

    If Len(m_strKey) = 0 Then
        m_lStatus = REGAGENT_NOKEY
        Exit Sub
    End If

    If Len(m_strSubKey) = 0 Then
        m_lStatus = REGAGENT_NOSUBKEY
        Exit Sub
    End If

    m_lStatus = RegOpenKeyEx(m_lRootKey, m_strKey, 0&, KEY_QUERY_VALUE, lKeyID) 'open the key
    If m_lStatus <> 0 Then
        Exit Sub
    End If
    If m_lStatus = 0 Then
        m_lStatus = RegDeleteValue(lKeyID, ByVal m_strSubKey)
    End If

End Sub

解决方案 »