'-------------------------------------------------------------------------------------------------
'sample usage - Debug.Print UpodateKey(HKEY_CLASSES_ROOT, "keyname", "newvalue")
'-------------------------------------------------------------------------------------------------
Public Function UpdateKey(KeyRoot As Long, KeyName As String, SubKeyName As String, SubKeyValue As String) As Boolean
Dim rc As Long ' 返回代码
Dim hKey As Long ' 处理一个注册表关键字
Dim hDepth As Long '
Dim lpAttr As SECURITY_ATTRIBUTES ' 注册表安全类型
If (rc <> ERROR_SUCCESS) Then GoTo CreateKeyError ' 错误处理
'------------------------------------------------------------
'- 关闭注册表关键字...
'------------------------------------------------------------
rc = RegCloseKey(hKey) ' 关闭关键字
UpdateKey = True ' 返回成功
Exit Function ' 退出
CreateKeyError:
UpdateKey = False ' 设置错误返回代码
rc = RegCloseKey(hKey) ' 试图关闭关键字
End Function
'-------------------------------------------------------------------------------------------------
'sample usage - Debug.Print GetKeyValue(HKEY_CLASSES_ROOT, "COMCTL.ListviewCtrl.1\CLSID", "")
'-------------------------------------------------------------------------------------------------
Public Function GetKeyValue(KeyRoot As Long, KeyName As String, SubKeyRef As String) As String
Dim i As Long ' 循环计数器
Dim rc As Long ' 返回代码
Dim hKey As Long ' 处理打开的注册表关键字
Dim hDepth As Long '
Dim sKeyVal As String
Dim lKeyValType As Long ' 注册表关键字数据类型
Dim tmpVal As String ' 注册表关键字的临时存储器
Dim KeyValSize As Long ' 注册表关键字变量尺寸
'---------------------------------------------------------------
'-注册表 API 声明...
'---------------------------------------------------------------
Private Declare Function RegCloseKey Lib "advapi32" (ByVal hKey As Long) As Long
Private Declare Function RegCreateKeyEx Lib "advapi32" 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, ByRef lpSecurityAttributes As SECURITY_ATTRIBUTES, ByRef phkResult As Long, ByRef lpdwDisposition As Long) As Long
Private Declare Function RegOpenKeyEx Lib "advapi32" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, ByRef phkResult As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, ByRef lpType As Long, ByVal lpData As String, ByRef lpcbData As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32" 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 Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Boolean
End Type
如果不明白,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
On Error Resume Next
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
If InStr(1, strBuf, Chr$(0)) > 1 Then
RegQueryStringValue = Left$(strBuf, InStr(1, strBuf, Chr$(0)) - 1)
ElseIf InStr(1, strBuf, Chr$(0)) = 1 Then
RegQueryStringValue = ""
ElseIf InStr(1, strBuf, Chr$(0)) = 0 Then
RegQueryStringValue = strBuf
End If
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) As String
Dim Ret As Long
'Open the key
If RegOpenKey(hKey, strPath, Ret) = ERROR_SUCCESS Then
'Get the key's content
GetString = RegQueryStringValue(Ret, strValue)
'Close the key
RegCloseKey Ret
End If
End Function
只需要调用
strResult= GetString (HKEY_LOCAL_MACHINE,"SYSTEM\Control\Class\{4D36E965-E325-11CE-BFC1-08002BE10318}",vbnullstring)
例:
首先新建一个工程,在新建的窗体上添加以下控件并设置相应属性:
控件名 属性 值
Label1 Caption 注册表键值:
Label2 Caption 注册姓名:
Label3 Caption 空
Label4 Caption 注册公司:
Label5 Caption 空
Label6 Caption 空
Text1 Text 空
Text2 Text 空
Command1 Caption 写入注册表
Command2 Caption 退出
然后,在程序的声明部分添加如下代码:
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 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
Const error_success = 0&
Const error_baddb = 1009&
Const error_badkey = 1010&
Const error_cantopen = 1011&
Const error_cantread = 1012&
Const error_cantwrite = 1013&
Const error_registry_recovered = 1014&
Const error_registry_corrupt = 1015&
Const error_registry_io_failed = 1016&
Const hkey_classes_root = &H80000000
Const hkey_current_user = &H80000001
Const hkey_local_machine = &H80000002
Const REG_SZ = 1
Const regkey = "softwareMy SoftMy program"
接着为各个控件添加代码,代码如下:
Private Sub Command1_Click()
Dim keyvalue As String
Dim retvalue As Long
Dim keyid As Long
retvalue = RegCreateKey(hkey_local_machine, regkey, keyid)
keyvalue = Text1.Text
retvalue = RegSetValueEx(keyid, "注册名", 0&, REG_SZ, ByVal keyvalue, Len(keyvalue) + 1)
keyvalue = Text2.Text
retvalue = RegSetValueEx(keyid, "注册公司", 0&, REG_SZ, ByVal keyvalue, Len(keyvalue) + 1)
If Text1.Text <> "" And Text2.Text <> "" Then
Label3.Caption = Text1.Text
Label5.Caption = Text2.Text
End If
End Sub
Private Sub Command2_Click()
Unload Me
End
End Sub
Private Sub Form_Load()
Dim retvalue As Long
Dim result As Long
Dim keyid As Long
Dim keyvalue As String
Dim subkey As String
Dim bufsize As Long
Label6.Caption = regkey
retvalue = RegCreateKey(hkey_local_machine, regkey, keyid)
If retvalue = 0 Then
subkey = "注册名"
retvalue = RegQueryValueEx(keyid, subkey, 0&, REG_SZ, 0&, bufsize)
If bufsize < 2 Then
keyvalue = ""
retvalue = RegSetValueEx(keyid, subkey, 0&, REG_SZ, ByVal keyvalue, Len(keyvalue) + 1)
Else
keyvalue = String(bufsize + 1, " ")
retvalue = RegQueryValueEx(keyid, subkey, 0&, REG_SZ, ByVal keyvalue, bufsize)
keyvalue = Left$(keyvalue, bufsize - 1)
Text1.Text = keyvalue
End If
Label3.Caption = keyvalue
subkey = "注册公司"
retvalue = RegQueryValueEx(keyid, subkey, 0&, REG_SZ, 0&, bufsize)
If bufsize < 2 Then
keyvalue = ""
retvalue = RegSetValueEx(keyid, subkey, 0&, REG_SZ, ByVal keyvalue, Len(keyvalue) + 1)
Else
keyvalue = String(bufsize + 1, " ")
retvalue = RegQueryValueEx(keyid, subkey, 0&, REG_SZ, ByVal keyvalue, bufsize)
keyvalue = Left$(keyvalue, bufsize - 1)
Text2.Text = keyvalue
End If
Label5.Caption = keyvalue
End If
End Sub