现在的位置: 首页 > 精选转贴 > 正文

VBA 操作注册表的模块

2014年06月10日 精选转贴 ⁄ 共 11363字 ⁄ 字号 暂无评论 ⁄ 阅读 2,250 次
注意: 本文适用于 Excel 2000 及其以后版本(包含 64 位 Office )

 

VBA 自带的注册表操作功能很弱,只能操作固定的键,很是不方便。这里收集了一个在 VBA 中操作注册表的模块,我对模块进行了一定的修改,使它可以用在 64 位的 Office 上面。非原创,网络收集。

   

001

 

Option Explicit
 
'---注册表主键---
Public Enum enumRegMainKey
    iHKEY_CLASSES_ROOT = &H80000000
    iHKEY_CURRENT_USER = &H80000001
    iHKEY_LOCAL_MACHINE = &H80000002
    iHKEY_USERS = &H80000003
    iHKEY_PERFORMANCE_DATA = &H80000004
    iHKEY_CURRENT_CONFIG = &H80000005
    iHKEY_DYN_DATA = &H80000006
End Enum
'---注册表数据类型---
Public Enum enumRegSzType
    iREG_SZ = &H1
    iREG_EXPAND_SZ = &H2
    iREG_BINARY = &H3
    iREG_DWORD = &H4
    iREG_NONE = 0&
    iREG_DWORD_LITTLE_ENDIAN = 4&
    iREG_DWORD_BIG_ENDIAN = 5&
    iREG_LINK = 6&
    iREG_MULTI_SZ = 7&
    iREG_RESOURCE_LIST = 8&
    iREG_FULL_RESOURCE_DEscrīptOR = 9&
    iREG_RESOURCE_REQUIREMENTS_LIST = 10&
End Enum
 
'---返回值和访问权限常数---
Private Const ERROR_SUCCESS = 0&
Private Const ERROR_BADDB = 1009&
Private Const ERROR_BADKEY = 1010&
Private Const ERROR_CANTOPEN = 1011&
Private Const ERROR_CANTREAD = 1012&
Private Const ERROR_CANTWRITE = 1013&
Private Const ERROR_OUTOFMEMORY = 14&
Private Const ERROR_INVALID_PARAMETER = 87&
Private Const ERROR_ACCESS_DENIED = 5&
Private Const ERROR_NO_MORE_ITEMS = 259&
Private Const ERROR_MORE_DATA = 234&
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 SYNCHRONIZE = &H100000
Private Const READ_CONTROL = &H20000
Private Const WRITE_DAC = &H40000
Private Const WRITE_OWNER = &H80000
Private Const STANDARD_RIGHTS_REQUIRED = &HF0000
Private Const STANDARD_RIGHTS_READ = READ_CONTROL
Private Const STANDARD_RIGHTS_WRITE = READ_CONTROL
Private Const STANDARD_RIGHTS_EXECUTE = READ_CONTROL
Private Const KEY_READ = STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY
Private Const KEY_WRITE = STANDARD_RIGHTS_WRITE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY
Private Const KEY_EXECUTE = ((KEY_READ) And (Not SYNCHRONIZE))
Private Const KEY_ALL_ACCESS = ((STANDARD_RIGHTS_ALL Or KEY_QUERY_VALUE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY Or KEY_CREATE_LINK) And (Not SYNCHRONIZE))
 
'---API 函数---
#If Win64 Then '64位
 Private Declare PtrSafe Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As LongPtr, ByVal lpSubKey As String, phkResult As LongPtr) As Long
 Private Declare PtrSafe Function RegCreateKeyEx Lib "advapi32.dll" Alias "RegCreateKeyExA" (ByVal hKey As LongPtr, ByVal lpSubKey As String, ByVal Reserved As Long, ByVal lpClass As String, ByVal dwOptions As Long, ByVal samDesired As Long, lpSecurityAttributes As SECURITY_ATTRIBUTES, phkResult As LongPtr, lpdwDisposition As Long) As Long
 Private Declare PtrSafe Function RegEnumValue Lib "advapi32.dll" Alias "RegEnumValueA" (ByVal hKey As LongPtr, ByVal dwIndex As Long, ByVal lpValueName As String, lpcbValueName As Long, ByVal lpReserved As LongPtr, lpType As Long, lpData As Byte, lpcbData As Long) As Long
 Private Declare PtrSafe Function RegEnumKeyEx Lib "advapi32.dll" Alias "RegEnumKeyExA" (ByVal hKey As LongPtr, ByVal dwIndex As Long, ByVal lpName As String, lpcbName As Long, ByVal lpReserved As LongPtr, ByVal lpClass As String, lpcbClass As Long, lpftLastWriteTime As FILETIME) As Long
 Private Declare PtrSafe Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As LongPtr, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As LongPtr) As Long
 Private Declare PtrSafe Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As LongPtr) As Long
 Private Declare PtrSafe Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As LongPtr, ByVal lpValueName As String) As Long
 Private Declare PtrSafe Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As LongPtr, 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 PtrSafe Function RegSetValueExLong Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As LongPtr, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As LongPtr, ByVal cbData As LongPtr) As Long
 Private Declare PtrSafe Function RegSetValueExA Lib "advapi32.dll" (ByVal hKey As LongPtr, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByRef lpData As LongPtr, ByVal cbData As LongPtr) As Long
 Private Declare PtrSafe Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As LongPtr, ByVal lpValueName As String, ByVal lpReserved As LongPtr, lpType As Long, lpData As Any, lpcbData As Long) As Long ' Note that if you declare the lpData parameter as String, you must pass it By Value.
 Private Declare PtrSafe Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As LongPtr, ByVal lpSubKey As String) As Long
 Private Declare PtrSafe Function RegSaveKey Lib "advapi32.dll" Alias "RegSaveKeyA" (ByVal hKey As LongPtr, ByVal lpFile As String, lpSecurityAttributes As SECURITY_ATTRIBUTES) As Long
 Private Declare PtrSafe Function RegRestoreKey Lib "advapi32.dll" Alias "RegRestoreKeyA" (ByVal hKey As LongPtr, ByVal lpFile As String, ByVal dwFlags As Long) As Long
#Else
 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 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, lpSecurityAttributes As SECURITY_ATTRIBUTES, phkResult As Long, lpdwDisposition As Long) As Long
 Private Declare Function RegEnumValue Lib "advapi32.dll" Alias "RegEnumValueA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpValueName As String, lpcbValueName As Long, ByVal lpReserved As Long, lpType As Long, lpData As Byte, lpcbData As Long) As Long
 Private Declare Function RegEnumKeyEx Lib "advapi32.dll" Alias "RegEnumKeyExA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, lpcbName As Long, ByVal lpReserved As Long, ByVal lpClass As String, lpcbClass As Long, lpftLastWriteTime As FILETIME) 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 RegCloseKey Lib "advapi32.dll" (ByVal hKey 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 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 String, ByVal cbData As Long) As Long
 Private Declare Function RegSetValueExLong Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Long, ByVal cbData As Long) As Long
 Private Declare Function RegSetValueExA Lib "advapi32.dll" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByRef lpData As Long, ByVal cbData 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 ' Note that if you declare the lpData parameter as String, you must pass it By Value.
 Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
 Private Declare Function RegSaveKey Lib "advapi32.dll" Alias "RegSaveKeyA" (ByVal hKey As Long, ByVal lpFile As String, ByVal lpSecurityAttributes As Long) As Long
 Private Declare Function RegRestoreKey Lib "advapi32.dll" Alias "RegRestoreKeyA" (ByVal hKey As Long, ByVal lpFile As String, ByVal dwflags As Long) As Long
#End If
 
Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type
 
#If Win64 Then '64位
    Private Type SECURITY_ATTRIBUTES
        nLength As Long
        lpSecurityDescrīptor As LongPtr
        bInheritHandle As Boolean
    End Type
#Else
    Private Type SECURITY_ATTRIBUTES
        nLength As Long
        lpSecurityDescriptor As Long
        bInheritHandle As Long
    End Type
#End If
 
'---取得值---
Public Function GetValue(ByVal mainKey As enumRegMainKey, _
                         ByVal subKey As String, _
                         ByVal keyV As String, _
                         ByRef sValue As Variant, _
                         Optional ByRef rlngErrNum As Long, _
                         Optional ByRef rstrErrDescr As String) As Boolean
    Dim hKey As Long, lType As Long, lBuffer As Long, sBuffer As String, lData As Long
    On Error GoTo GetValueErr
    GetValue = False
    If RegOpenKeyEx(mainKey, subKey, 0, KEY_READ, hKey) <> ERROR_SUCCESS Then
        Err.Raise vbObjectError + 1, , "获取注册表值时出错"
    End If
    If RegQueryValueEx(hKey, keyV, 0, lType, ByVal 0, lBuffer) <> ERROR_SUCCESS Then
        Err.Raise vbObjectError + 1, , "获取注册表值时出错"
    End If
    Select Case lType
    Case iREG_SZ
        lBuffer = 255
        sBuffer = Space(lBuffer)
        If RegQueryValueEx(hKey, keyV, 0, lType, ByVal sBuffer, lBuffer) <> ERROR_SUCCESS Then
            Err.Raise vbObjectError + 1, , "获取注册表值时出错"
        End If
        sValue = Left(sBuffer, InStr(sBuffer, Chr(0)) - 1)
    Case iREG_EXPAND_SZ
        sBuffer = Space(lBuffer)
        If RegQueryValueEx(hKey, keyV, 0, lType, ByVal sBuffer, lBuffer) <> ERROR_SUCCESS Then
            Err.Raise vbObjectError + 1, , "获取注册表值时出错"
        End If
        sValue = Left(sBuffer, InStr(sBuffer, Chr(0)) - 1)
    Case iREG_DWORD
        If RegQueryValueEx(hKey, keyV, 0, lType, lData, lBuffer) <> ERROR_SUCCESS Then
            Err.Raise vbObjectError + 1, , "获取注册表值时出错"
        End If
        sValue = lData
    Case iREG_BINARY
        If RegQueryValueEx(hKey, keyV, 0, lType, lData, lBuffer) <> ERROR_SUCCESS Then
            Err.Raise vbObjectError + 1, , "获取注册表值时出错"
        End If
        sValue = lData
    End Select
    If RegCloseKey(hKey) <> ERROR_SUCCESS Then
        Err.Raise vbObjectError + 1, , "获取注册表值时出错"
    End If
    GetValue = True
    Err.Clear
GetValueErr:
    rlngErrNum = Err.Number
    rstrErrDescr = Err.Descrīption
End Function
 
'----赋值---
Public Function SetValue(ByVal mainKey As enumRegMainKey, _
                         ByVal subKey As String, _
                         ByVal keyV As String, _
                         ByVal lType As enumRegSzType, _
                         ByVal sValue As Variant, _
                         Optional ByRef rlngErrNum As Long, _
                         Optional ByRef rstrErrDescr As String) As Boolean
    Dim S As Long, lBuffer As Long, hKey As Long
    Dim ss As SECURITY_ATTRIBUTES
    On Error GoTo SetValueErr
    SetValue = False
    ss.nLength = Len(ss)
    ss.lpSecurityDescrīptor = 0
    ss.bInheritHandle = True
    If RegCreateKeyEx(mainKey, subKey, 0, "", 0, KEY_WRITE, ss, hKey, S) <> ERROR_SUCCESS Then
        Err.Raise vbObjectError + 1, , "设置注册表时出错"
    End If
    Select Case lType
    Case iREG_SZ
        lBuffer = LenB(sValue)
        If RegSetValueEx(hKey, keyV, 0, lType, ByVal sValue, lBuffer) <> ERROR_SUCCESS Then
             Err.Raise vbObjectError + 1, , "设置注册表时出错"
        End If
    Case iREG_EXPAND_SZ
        lBuffer = LenB(sValue)
        If RegSetValueEx(hKey, keyV, 0, lType, ByVal sValue, lBuffer) <> ERROR_SUCCESS Then
            Err.Raise vbObjectError + 1, , "设置注册表时出错"
        End If
    Case iREG_DWORD
        lBuffer = 4
        If RegSetValueExA(hKey, keyV, 0, lType, sValue, lBuffer) <> ERROR_SUCCESS Then
            Err.Raise vbObjectError + 1, , "设置注册表时出错"
        End If
    Case iREG_BINARY
        lBuffer = 4
        If RegSetValueExA(hKey, keyV, 0, lType, sValue, lBuffer) <> ERROR_SUCCESS Then
            Err.Raise vbObjectError + 1, , "设置注册表时出错"
        End If
    Case Else
        Err.Raise vbObjectError + 1, , "不支持该参数类型"
    End Select
    If RegCloseKey(hKey) <> ERROR_SUCCESS Then
        Err.Raise vbObjectError + 1, , "设置注册表时出错"
    End If
    SetValue = True
    Err.Clear
SetValueErr:
    rlngErrNum = Err.Number
    rstrErrDescr = Err.Descrīption
End Function
 
'---删除值---
Public Function DeleteValue(ByVal mainKey As enumRegMainKey, _
                            ByVal subKey As String, _
                            ByVal keyV As String, _
                            Optional ByRef rlngErrNum As Long, _
                            Optional ByRef rstrErrDescr As String) As Boolean
    Dim hKey As Long
    On Error GoTo DeleteValueErr
    DeleteValue = False
    If RegOpenKeyEx(mainKey, subKey, 0, KEY_WRITE, hKey) <> ERROR_SUCCESS Then
        Err.Raise vbObjectError + 1, , "删除注册表值时出错"
    End If
    If RegDeleteValue(hKey, keyV) <> ERROR_SUCCESS Then
        Err.Raise vbObjectError + 1, , "删除注册表值时出错"
    End If
    If RegCloseKey(hKey) <> ERROR_SUCCESS Then
        Err.Raise vbObjectError + 1, , "删除注册表值时出错"
    End If
    DeleteValue = True
    Err.Clear
DeleteValueErr:
    rlngErrNum = Err.Number
    rstrErrDescr = Err.Descrīption
End Function
 
'---删除项---
Public Function DeleteKey(ByVal mainKey As enumRegMainKey, _
                          ByVal subKey As String, _
                          ByVal keyV As String, _
                          Optional ByRef rlngErrNum As Long, _
                          Optional ByRef rstrErrDescr As String) As Boolean
    Dim hKey As Long
    On Error GoTo DeleteKeyErr
    DeleteKey = False
    If RegOpenKeyEx(mainKey, subKey, 0, KEY_WRITE, hKey) <> ERROR_SUCCESS Then
        Err.Raise vbObjectError + 1, , "删除注册表值时出错"
    End If
    If RegDeleteKey(hKey, keyV) <> ERROR_SUCCESS Then
        Err.Raise vbObjectError + 1, , "删除注册表值时出错"
    End If
    If RegCloseKey(hKey) <> ERROR_SUCCESS Then
        Err.Raise vbObjectError + 1, , "删除注册表值时出错"
    End If
    DeleteKey = True
    Err.Clear
DeleteKeyErr:
    rlngErrNum = Err.Number
    rstrErrDescr = Err.Descrīption
End Function

 

 

给我留言

您必须 [ 登录 ] 才能发表留言!