请问VB在注册表编程中如何建一个项，子键及键值？

野猫III

如：我想在注册表的：
HKEY_LOCAL_MACHINE\Software\

中新建一个VB1的项，里面建一个VB2的子键，键值为字符串VB3,谢谢！

＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋

'根键常数   
  　　Const   HKEY_CLASSES_ROOT   =   -2147483648#   
  　　Const   HKEY_CURRENT_USER   =   -2147483647#   
  　　Const   HKEY_LOCAL_MACHINE   =   -2147483646#   
  　　Const   HKEY_USERS   =   -2147483645#   

  　　'键值类型   
  　　Const   REG_SZ   =   1&   '字符串值   
  　　Const   REG_BINARY   =   3&   '二进制值   
  　　Const   REG_DWORD   =   4&   'DWORD   值   

参考：VB中怎样读写注册表？
http://topic.csdn.net/t/20010719/14/200569.html

Visual Basic 6 绿色简化版
http://www.zwye.com/Soft/1542.htm

[ 本帖最后由 野猫III 于 2007-1-8 10:37 编辑 ]

野猫III

VB编程操作注册表      
编程资料 2004-12-20 13:15
VB编程操作注册表

　　本示例将制作一个可以在注册表中增加或删除子键和键值的程序，左图为效果图，可图为设计窗体布局图。
　　注册表是系统管理计算机硬件和软件环境的数据库，在Windows中可以运行Regedit.exe程序来修改和维护注册表，作为编程人员有时希望能在自己的程序中操作注册表，虽然ＶＢ提供了相应的功能，但只能在特写的主键下进行，以下示例通过调用ＡＰＩ函数来进行。代码中的操作方法或许在你编写操作注册表的相关程序时有用处。
　　程序窗体上布置了三个框架，在框架中布置了９个Command按钮，布局如下右图所示。
　
'窗体Form1(Name=Registry)代码
Private Sub Cancel_Click()
Unload Me '退出程序
End Sub

Private Sub Createkey_Click()
rtn = CreateKey("HKEY_CLASSES_ROOT")
End Sub

Private Sub Createkeys_Click()
'新建一个子键.
CreateKey "HKEY_LOCAL_MACHINE\Registry Editor"
MsgBox "A Key has been created in you system registry at:" + Chr(10) + Chr(10) + "HKEY_LOCAL_MACHINE\Registry Demo"
End Sub

Private Sub Deletekeys_Click()
'删除一个子键,包括其下的所有子键
DeleteKey "HKEY_LOCAL_MACHINE\Registry Editor"
MsgBox "A Key has been deleted in you system registry at:" + Chr(10) + Chr(10) + "HKEY_LOCAL_MACHINE\Registry Demo"
End Sub

Private Sub Form_Load()
Move (Screen.Width - Width) \ 2, (Screen.Height - Height) \ 2 'centre the form on the screen
End Sub

Private Sub Readbinary_Click()
'获取值为二进制值的值项"Binary value"
rtn = GetBinaryvalue("HKEY_LOCAL_MACHINE", "Binary value")
If rtn = Chr$(&H1) + Chr$(&H2) + Chr$(&H3) + Chr$(&H4) Then
MsgBox "The value was returned successfully..."
End If
End Sub

Private Sub Readdword_Click()
'获取值为DWORD值的值项"DWORD value"
MsgBox GetDWORDvalue("HKEY_LOCAL_MACHINE", "DWORD value")
End Sub

Private Sub Readstring_Click()
'获取值为串值的值项"String value"
MsgBox GetStringvalue("HKEY_LOCAL_MACHINE", "String value")
End Sub

Private Sub Writebinary_Click()
'写二进制值的值项,值为"01 02 03 04"
SetBinaryvalue "HKEY_LOCAL_MACHINE", "Binary value", Chr$(&H1) + Chr$(&H2) + Chr$(&H3) + Chr$(&H4)
MsgBox "A Binary value has been created in you system registry at:" + Chr(10) + Chr(10) + "HKEY_LOCAL_MACHINE" + Chr(10) + Chr(10) + "The Binary was called ""Binary value"" and the value written was:" + Chr(10) + Chr(10) + "01 02 03 04"
End Sub

Private Sub Writedword_Click()
'写DWORD值的值项"DWORD value",值为"1"
SetDWORDvalue "HKEY_LOCAL_MACHINE", "DWORD value", "1"
MsgBox "A DWORD value has been created in you system registry at:" + Chr(10) + Chr(10) + "HKEY_LOCAL_MACHINE" + Chr(10) + Chr(10) + "The DWORD was called ""Dword value"" and the value written was:" + Chr(10) + Chr(10) + "1"
End Sub

Private Sub Writestring_Click()
'写串值的值项"String value",值为
SetStringvalue "HKEY_LOCAL_MACHINE", "String value", "Hello Visual Basic programmer"
MsgBox "A String value has been created in you system registry at:" + Chr(10) + Chr(10) + "HKEY_LOCAL_MACHINE" + Chr(10) + Chr(10) + "The String was called ""String value"" and the value written was:" + Chr(10) + Chr(10) + "Hello Registry"
End Sub

'模块Module1代码内容
Type FILETIME
lLowDateTime As Long
lHighDateTime As Long
End Type

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
Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
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 String, lpcbData As Long) As Long
Declare Function RegQueryvalueExA Lib "advapi32.dll" (ByVal hKey As Long, ByVal lpvalueName As String, ByVal lpReserved As Long, lpType As Long, ByRef lpData As Long, lpcbData As Long) As Long
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
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
Declare Function RegSetvalueExB Lib "advapi32.dll" Alias "RegSetvalueExA" (ByVal hKey As Long, ByVal lpvalueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByRef lpData As Byte, 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_OUTOFMEMORY = 14&
Const ERROR_INVALID_PARAMETER = 87&
Const ERROR_ACCESS_DENIED = 5&
Const ERROR_NO_MORE_ITEMS = 259&
Const ERROR_MORE_DATA = 234&
Const REG_NONE = 0&
Const REG_SZ = 1&
Const REG_EXPAND_SZ = 2&
Const REG_BINARY = 3&
Const REG_DWORD = 4&
Const REG_DWORD_LITTLE_ENDIAN = 4&
Const REG_DWORD_BIG_ENDIAN = 5&
Const REG_LINK = 6&
Const REG_MULTI_SZ = 7&
Const REG_RESOURCE_LIST = 8&
Const REG_FULL_RESOURCE_DESCRIPTOR = 9&
Const REG_RESOURCE_REQUIREMENTS_LIST = 10&
Const KEY_QUERY_value = &H1&
Const KEY_SET_value = &H2&
Const KEY_CREATE_SUB_KEY = &H4&
Const KEY_ENUMERATE_SUB_KEYS = &H8&
Const KEY_NOTIFY = &H10&
Const KEY_CREATE_LINK = &H20&
Const READ_CONTROL = &H20000
Const WRITE_DAC = &H40000
Const WRITE_OWNER = &H80000
Const SYNCHRONIZE = &H100000
Const STANDARD_RIGHTS_REQUIRED = &HF0000
Const STANDARD_RIGHTS_READ = READ_CONTROL
Const STANDARD_RIGHTS_WRITE = READ_CONTROL
Const STANDARD_RIGHTS_EXECUTE = READ_CONTROL
Const KEY_READ = STANDARD_RIGHTS_READ Or KEY_QUERY_value Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY
Const KEY_WRITE = STANDARD_RIGHTS_WRITE Or KEY_SET_value Or KEY_CREATE_SUB_KEY
Const KEY_EXECUTE = KEY_READ
Const DisplayErrorMsg = False
Dim hKey As Long, MainKeyHandle As Long
Dim rtn As Long, lBuffer As Long, sBuffer As String
Dim lBufferSize As Long
Dim lDataSize As Long
Dim ByteArray() As Byte

Function SetDWORDvalue(SubKey As String, Entry As String, value As Long)
Call ParseKey(SubKey, MainKeyHandle)
If MainKeyHandle Then
rtn = RegOpenKeyEx(MainKeyHandle, SubKey, 0, KEY_WRITE, hKey) '打开一个子键
If rtn = ERROR_SUCCESS Then '如果子键已成功打开
rtn = RegSetvalueExA(hKey, Entry, 0, REG_DWORD, value, 4) '写键值
If Not rtn = ERROR_SUCCESS Then '如果写时出错
If DisplayErrorMsg = True Then '如果需要显示错误
MsgBox ErrorMsg(rtn) '显示错误
End If
End If
rtn = RegCloseKey(hKey) '关闭子键
Else '如果子键已打开出错
If DisplayErrorMsg = True Then '如果需要显示错误
MsgBox ErrorMsg(rtn) '显示错误
End If
End If
End If
End Function

Function GetDWORDvalue(SubKey As String, Entry As String)
Call ParseKey(SubKey, MainKeyHandle)
If MainKeyHandle Then
rtn = RegOpenKeyEx(MainKeyHandle, SubKey, 0, KEY_READ, hKey) ''打开一个子键
If rtn = ERROR_SUCCESS Then '如果子键可以打开
rtn = RegQueryvalueExA(hKey, Entry, 0, REG_DWORD, lBuffer, 4) '从注册表中获得值项
If rtn = ERROR_SUCCESS Then '如果子键已打开出错
rtn = RegCloseKey(hKey) '关闭子键
GetDWORDvalue = lBuffer '返回值项的值
Else
GetDWORDvalue = "Error" '返回错误信息
If DisplayErrorMsg = True Then '如果需要显示错误
MsgBox ErrorMsg(rtn) '显示错误
End If
End If
Else
GetDWORDvalue = "Error"
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
End If
End Function

Function SetBinaryvalue(SubKey As String, Entry As String, value As String)
Call ParseKey(SubKey, MainKeyHandle)
If MainKeyHandle Then
rtn = RegOpenKeyEx(MainKeyHandle, SubKey, 0, KEY_WRITE, hKey) 'open the key
If rtn = ERROR_SUCCESS Then
lDataSize = Len(value)
ReDim ByteArray(lDataSize)
For i = 1 To lDataSize
ByteArray(i) = Asc(Mid$(value, i, 1))
Next
rtn = RegSetvalueExB(hKey, Entry, 0, REG_BINARY, ByteArray(1), lDataSize) 'write the value
If Not rtn = ERROR_SUCCESS Then
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
rtn = RegCloseKey(hKey)
Else
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
End If
End Function

Function GetBinaryvalue(SubKey As String, Entry As String)
Call ParseKey(SubKey, MainKeyHandle)
If MainKeyHandle Then
rtn = RegOpenKeyEx(MainKeyHandle, SubKey, 0, KEY_READ, hKey)
If rtn = ERROR_SUCCESS Then
lBufferSize = 1
rtn = RegQueryvalueEx(hKey, Entry, 0, REG_BINARY, 0, lBufferSize)
sBuffer = Space(lBufferSize)
rtn = RegQueryvalueEx(hKey, Entry, 0, REG_BINARY, sBuffer, lBufferSize)
If rtn = ERROR_SUCCESS Then
rtn = RegCloseKey(hKey)
GetBinaryvalue = sBuffer
Else
GetBinaryvalue = "Error"
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
Else
GetBinaryvalue = "Error"
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
End If
End Function

Function DeleteKey(Keyname As String)
Call ParseKey(Keyname, MainKeyHandle)
If MainKeyHandle Then
rtn = RegOpenKeyEx(MainKeyHandle, Keyname, 0, KEY_WRITE, hKey)
If rtn = ERROR_SUCCESS Then
rtn = RegDeleteKey(hKey, Keyname)
rtn = RegCloseKey(hKey)
End If
End If
End Function

Function GetMainKeyHandle(MainKeyName As String) As Long
Const HKEY_CLASSES_ROOT = &H80000000
Const HKEY_CURRENT_USER = &H80000001
Const HKEY_LOCAL_MACHINE = &H80000002
Const HKEY_USERS = &H80000003
Const HKEY_PERFORMANCE_DATA = &H80000004
Const HKEY_CURRENT_CONFIG = &H80000005
Const HKEY_DYN_DATA = &H80000006
Select Case MainKeyName
Case "HKEY_CLASSES_ROOT"
GetMainKeyHandle = HKEY_CLASSES_ROOT
Case "HKEY_CURRENT_USER"
GetMainKeyHandle = HKEY_CURRENT_USER
Case "HKEY_LOCAL_MACHINE"
GetMainKeyHandle = HKEY_LOCAL_MACHINE
Case "HKEY_USERS"
GetMainKeyHandle = HKEY_USERS
Case "HKEY_PERFORMANCE_DATA"
GetMainKeyHandle = HKEY_PERFORMANCE_DATA
Case "HKEY_CURRENT_CONFIG"
GetMainKeyHandle = HKEY_CURRENT_CONFIG
Case "HKEY_DYN_DATA"
GetMainKeyHandle = HKEY_DYN_DATA
End Select
End Function

Function ErrorMsg(lErrorCode As Long) As String
'显示错误信息
Select Case lErrorCode
Case 1009, 1015
GetErrorMsg = "The Registry Database is corrupt!"
Case 2, 1010
GetErrorMsg = "Bad Key Name"
Case 1011
GetErrorMsg = "Can't Open Key"
Case 4, 1012
GetErrorMsg = "Can't Read Key"
Case 5
GetErrorMsg = "Access to this key is denied"
Case 1013
GetErrorMsg = "Can't Write Key"
Case 8, 14
GetErrorMsg = "Out of memory"
Case 87
GetErrorMsg = "Invalid Parameter"
Case 234
GetErrorMsg = "There is more data than the buffer has been allocated to hold."
Case Else
GetErrorMsg = "Undefined Error Code: " & Str$(lErrorCode)
End Select
End Function

Function GetStringvalue(SubKey As String, Entry As String)
Call ParseKey(SubKey, MainKeyHandle)
If MainKeyHandle Then
rtn = RegOpenKeyEx(MainKeyHandle, SubKey, 0, KEY_READ, hKey)
If rtn = ERROR_SUCCESS Then
sBuffer = Space(255)
lBufferSize = Len(sBuffer)
rtn = RegQueryvalueEx(hKey, Entry, 0, REG_SZ, sBuffer, lBufferSize)
If rtn = ERROR_SUCCESS Then
rtn = RegCloseKey(hKey)
sBuffer = Trim(sBuffer)
GetStringvalue = Left(sBuffer, Len(sBuffer) - 1)
Else: GetStringvalue = "Error"
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
Else
GetStringvalue = "Error"
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
End If
End Function

Private Sub ParseKey(Keyname As String, Keyhandle As Long)
rtn = InStr(Keyname, "\") '如果键值中包含"\"则返回
If Left(Keyname, 5) <> "HKEY_" Or Right(Keyname, 1) = "\" Then '如果"\"在键值的末尾
MsgBox "Incorrect Format:" + Chr(10) + Chr(10) + Keyname '显示错误信息
Exit Sub
ElseIf rtn = 0 Then '如果键值中不包含"\"
Keyhandle = GetMainKeyHandle(Keyname)
Keyname = "" '把键值设为空
Else
Keyhandle = GetMainKeyHandle(Left(Keyname, rtn - 1)) '分离键值
Keyname = Right(Keyname, Len(Keyname) - rtn)
End If
End Sub

Function CreateKey(SubKey As String)
Call ParseKey(SubKey, MainKeyHandle)
If MainKeyHandle Then
rtn = RegCreateKey(MainKeyHandle, SubKey, hKey)
If rtn = ERROR_SUCCESS Then
rtn = RegCloseKey(hKey)
End If
End If
End Function

Function SetStringvalue(SubKey As String, Entry As String, value As String)
Call ParseKey(SubKey, MainKeyHandle)
If MainKeyHandle Then
rtn = RegOpenKeyEx(MainKeyHandle, SubKey, 0, KEY_WRITE, hKey)
If rtn = ERROR_SUCCESS Then
rtn = RegSetvalueEx(hKey, Entry, 0, REG_SZ, ByVal value, Len(value))
If Not rtn = ERROR_SUCCESS Then
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
rtn = RegCloseKey(hKey)
Else
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
End If
End Function

caterpilla

资料齐全啊，呵呵。

野猫III

梦里水香 23:40:02
uses Registry;
梦里水香 23:40:10
procedure TForm1.Button1Click(Sender: TObject);
var
  registerTemp:TRegistry;
begin
  registerTemp := TRegistry.Create; //创建一个TRegistry对象
  with registerTemp do
  begin
    RootKey:=HKEY_LOCAL_MACHINE; //根
    if OpenKey('Software\vb1',true) then // true时如果不存在则建立。false则不建立
    begin
      if valueexists('vb2') then      //查看值是否存在
      begin
        showmessage('读取vb2的值为：'+readString('vb2')+'再写入111111'); //取值
        WriteString('vb2','111111');//写入注册表中。
      end
      else
      begin
        WriteString('vb2','222222'); //写入注册表中。
        showmessage('vb2值不存在，新建并写入：222222');
      end;
    end;
    CloseKey;
    Destroy;
  end;
end;

procedure TForm1.Button2Click(Sender: TObject);
var
  reg1:Tregistry;
begin
  reg1:=Tregistry.Create;
  with reg1 do
  begin
    rootkey:=HKEY_LOCAL_MACHINE;
    if OpenKey('Software\vb1',false) then
      if DeleteValue('vb2') then       //删除值
        showmessage('删除值vb2成功');
    CloseKey;
    if OpenKey('Software',false) then
      if Deletekey('vb1') then         //删除项
        showmessage('删除项vb1成功');
    CloseKey;
    Destroy;
  end;
end;

annatata

野猫辛苦了啊！