Excel VBA 操作注册表的模块 实现代码
发布时间:2023-06-23 14:37:36
VBA 自带的注册表操作功能很弱,只能操作固定的键,很是不方便。这里收集了一个在 VBA 中操作注册表的模块,我对模块进行了一定的修改,使它可以用在 64 位的 Office 上面。
Excel VBA 操作注册表的模块 实现代码
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
Excel VBA 操作注册表的模块 实现代码的下载地址:
猜你喜欢
- 图表好比超市,商品的种类数量以及所处位置不由顾客直接决定,但顾客的意愿和喜好决定着商品是否被购买,以及购买数量的多少。图表的目标读者我们称之
- Excel中经常需要使用到框线分类数据,框线具体该如何设置成显示的呢?下面是小编带来的关于excel表格框线设置成显示的方法,希望阅读过后对
- Excel2010怎么排序?这篇文章主要介绍了Excel2010数据排序功能使用教程,需要的朋友可以参考下在使用excel表格的时候,我们通
- Excel2016最近使用的工作簿的记录怎么删除?Excel2016经常打开文件,时间长了会出现很多打开的工作薄的记录,该怎么删除这些记录呢
- Excel表格中单元格区域选取,竟然有这么多种方法,你都知道吗?要选取一个单元格区域,除了常规的鼠标拖选,还有多少其他的可行方法?如果有数万
- WORD的公式编辑器不能用了.怎么办呢.下面请看解决方法有网友给小编说用word2007插入一个文档,然后就使用公式编辑器可以进行数据运算。
- 固定Excel首行,就是首行下方的所有行,在随着滚动条滚动时,首行并不会消失,而是总保持在首行的位置。下面是由小编分享的excel表格首行固
- 这篇文章主要是向脚本之家的朋友介绍利用Excel和bat批处理命令快速批量创建指定文件夹方法,教程真的很不错,很值得大家学习,推荐到脚本之家
- 很多使用Win10专业版电脑的用户想必电脑上都会配置耳麦,但是只插入耳麦并不能让耳麦直接使用,需要对其进行设置才行。本篇教程就是教大家Win
- 本文介绍MicrosoftExcel中MEDIAN函数的公式语法和用法。说明返回一组已知数字的中值。中值是一组数的中间数。语法MEDIAN(
- 刚刚学习excel的朋友在看excel教程的时候可能会遇见这样的问题,excel工作簿和工作表是什么关系啊?这时很多人会问的一个问题,当然有
- 有时我们得到的文档或下载的文档设置了背景色,有的人对该背景色看的不习惯,或不舒服,向更换该文档的背景色,设置为自己喜欢的颜色,或设置为默认的
- 下面提供给大家具体的制作过程: 1、源数据如下: 首先做好正方形一个,然后复制3份,最后拼成这样 &
- win10电脑熄屏不关机快捷键怎么设置?用户通常不会去搞懂功能时如何实现的,他们更注重功能的高效运用以及实用性。win10电脑要想息屏,最好
- 在制作Word文档的时候我们有时候需要将文字设置成闪烁不断的效果和具有霓虹灯样的效果,那么这些效果我们如果在Word中实现了,下面跟我们一起
- 1、启动Excel2013,圈中数据区域,单击菜单栏--插入--柱形图,选择二维柱形图中的簇状柱形图。 2、鼠标选
- 当我在使用Word 2007编辑考试试题的时候,我都是习惯性的将答案已经写进去,但是打印试卷的时候却需要没有填写答案的试卷文档。这个时候再去
- word标尺作用:word标尺分别有水平标尺和垂直标尺。word标尺的作用常常用于对齐文档中的文本、图形、表格和其余一些元素。word标尺在
- 导航到HKEY_CURRENT_USER\Software\Classes\.html 项 3、在默认项上点右键选择修改 4、将Max2.A
- Abbyy FineReader14怎么识别图片中的文字?FineReader14导入的图片想要提取文字,该怎么提取图片中的文字呢?下面我们