Visual Basic y el registro del sistema

Prueba con lo siguiente:
'**************************
'EN UN MODULO
'**************************
Type FILETIME
lLowDateTime As Long
lHighDateTime As Long
End Type
'////////////////////////////////
'//// CLAVES DEL REGISTRO /////
'////////////////////////////////
Public Const HKEY_CLASSES_ROOT = &H80000000
Public Const HKEY_CURRENT_USER = &H80000001
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public Const HKEY_USERS = &H80000003
Public Const HKEY_PERFORMANCE_DATA = &H80000004
Public Const HKEY_CURRENT_CONFIG = &H80000005
Public Const HKEY_DYN_DATA = &H80000006
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
Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) 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
Dim hKey As Long, MainKeyHandle As Long
Dim Result As Long, lBuffer As Long, sBuffer As String
Dim lBufferSize As Long
Dim lDataSize As Long
Dim ByteArray() As Byte
'Esta constante determina si muestra un mensaje de error al
'usuario. Yo he colocado el predeterminado valorado a Falso como un mensaje de error puede y
'llega a ser irritando después de un while. Vuelva este valor a True si usted quiere
'depurar su código programador cuando leyendo y escribiendo a su sistema
'del registro, como cualquier errores se mostrarán en una caja de mensaje.
Const DisplayErrorMsg = False
Function EscribirValorDWORD(Entrada As Long, Clave As String, NomValor As String, Valor As Long) As Boolean
'Call ParseKey(SubKey, MainKeyHandle)
EscribirValorDWORD = True
Result = RegOpenKeyEx(Entrada, Clave, 0, KEY_WRITE, hKey) 'Abirmos la Llave
If Result = ERROR_SUCCESS Then 'si la llave se abrio exitosamente entonces
Result = RegSetValueExA(hKey, NomValor, 0, REG_DWORD, Valor, 4) 'Escribo los valores
If Not Result = ERROR_SUCCESS Then 'si había un error al escribir el valor
EscribirValorDWORD = False
If DisplayErrorMsg = True Then 'si el usuario quiere que los errores se muestren
MsgBox ErrorMsg(Result) 'Muestra el error
End If
End If
Result = RegCloseKey(hKey) 'Cerramos la Llave
Else 'si había un error al abrir la llave
EscribirValorDWORD = False
If DisplayErrorMsg = True Then 'si el usuario quiere que los errores se muestren
MsgBox ErrorMsg(Result) 'Muestra el error
End If
End If
End Function
Function LeerValorDWORD(Entrada As Long, Clave As String, Valor As String)
'Call ParseKey(SubKey, MainKeyHandle)
Result = RegOpenKeyEx(Entrada, Clave, 0, KEY_READ, hKey) 'Abrimos la Llave
If Result = ERROR_SUCCESS Then 'Si no hay error
Result = RegQueryValueExA(hKey, Valor, 0, REG_DWORD, lBuffer, 4) 'Leemos el valor del registro
If Result = ERROR_SUCCESS Then 'Si no hay error al leer
Result = RegCloseKey(hKey) 'cerramos la llave
LeerValorDWORD = lBuffer 'Valor de retorno
Else 'Si hay un error
LeerValorDWORD = "Error" 'Retorno al usuario
If DisplayErrorMsg = True Then 'Si se desea poner error
MsgBox ErrorMsg(Result) 'Mostramos el error
End If
End If
Else 'Si hay error al abrir la Llave
LeerValorDWORD = "Error" 'retornamos error
If DisplayErrorMsg = True Then 'Si se desea poner error
MsgBox ErrorMsg(Result) 'mostramos el error
End If
End If
End Function
Private Sub ParseKey(Keyname As String, Keyhandle As Long)
Result = InStr(Keyname, "\") 'return if "\" is contained in the Keyname
If Left(Keyname, 5) <> "HKEY_" Or Right(Keyname, 1) = "\" Then 'if the is a "\" at the end of the Keyname then
MsgBox "Incorrect Format:" + Chr(10) + Chr(10) + Keyname 'display error to the user
Exit Sub 'exit the procedure
ElseIf Result = 0 Then 'if the Keyname contains no "\"
'Keyhandle = GetMainKeyHandle(Keyname)
Keyname = "" 'leave Keyname blank
Else 'otherwise, Keyname contains "\"
' Keyhandle = GetMainKeyHandle(Left(Keyname, Result - 1)) 'seperate the Keyname
Keyname = Right(Keyname, Len(Keyname) - Result)
End If
End Sub
Function ErrorMsg(lErrorCode As Long) As String
'Si un error ocurre, y el usuario quiere mostar los mensajes de error,
'entonces muestre uno de los mensajes siguientes de error
Select Case lErrorCode
Case 1009, 1015
ErrorMsg = "Base de datos de Registro corrupta"
Case 2, 1010
ErrorMsg = "Nombre de clave equivocada"
Case 1011
ErrorMsg = "Imposible abrir llave"
Case 4, 1012
ErrorMsg = "Imposible Leer Llave"
Case 5
ErrorMsg = "El acceso a esta llave denegado"
Case 1013
ErrorMsg = "Imposible escribir en llave"
Case 8, 14
ErrorMsg = "Memoria insuficiente"
Case 87
ErrorMsg = "Parametro no valido"
Case 234
ErrorMsg = "Desbordamiento de pila"
Case Else
ErrorMsg = "Codigo de error indefinido: " & Str$(lErrorCode)
End Select
End Function
Function EscribirValorSTRING(Entrada As Long, Clave As String, NomValor As String, Valor As String) As String
Result = RegOpenKeyEx(Entrada, Clave, 0, KEY_WRITE, hKey) 'abrimos la llave
If Result = ERROR_SUCCESS Then 'Si no hay error al abrir
Result = RegSetValueEx(hKey, NomValor, 0, REG_SZ, ByVal Valor, Len(Valor)) 'Leo el valor
If Not Result = ERROR_SUCCESS Then 'SI HAY UN ERROR AL ESCRIBIR EL VALOR
If DisplayErrorMsg = True Then 'si hay que visualizar el error
MsgBox ErrorMsg(Result) 'vemos el error
End If
End If
Result = RegCloseKey(hKey) 'cerramos la llave
Else 'si hay un error al abrir la clave
If DisplayErrorMsg = True Then 'si esta activado la visializacion de errores
MsgBox ErrorMsg(Result) 'visualizamos el error
End If
End If
End Function
Function LeerValorSTRING(Entrada As Long, Clave As String, NomValor As String)
Result = RegOpenKeyEx(Entrada, Clave, 0, KEY_READ, hKey) 'Abrimos la llave
If Result = ERROR_SUCCESS Then 'Si no hay error al abrir la llave
sBuffer = String(255, " ") 'Marcamos el Buffer
lBufferSize = Len(sBuffer)
Result = RegQueryValueEx(hKey, NomValor, 0, REG_SZ, sBuffer, lBufferSize) 'get the value from the registry
If Result = ERROR_SUCCESS Then 'Si leer tuvo exito
Result = RegCloseKey(hKey) 'CERRAMOS LA CLAVE
sBuffer = Trim(sBuffer)
LeerValorSTRING = Left(sBuffer, Len(sBuffer) - 1) 'RETORNAMOS EL VALOR AL BUFFER
Else 'SI HUBO UN ERROR AL LEER
LeerValorSTRING = "Error" 'retornamos "Error" al usuario
If DisplayErrorMsg = True Then 'si esta activado los mensajes de errores
MsgBox ErrorMsg(Result) 'mostramos al usuario el error
End If
End If
Else 'si hay un error al abrir la llave
LeerValorSTRING = "Error" 'retornamos el error al usuario
If DisplayErrorMsg = True Then 'si esta activado los mensajes de errores
MsgBox ErrorMsg(Result) 'mostramos al usuario el error
End If
End If
End Function
Function CrearLlave(Entrada As Long, Clave As String) As Boolean
'Call ParseKey(SubKey, MainKeyHandle)
Result = RegCreateKey(Entrada, Clave, hKey) 'create the key
If Result = ERROR_SUCCESS Then 'if the key was created then
Result = RegCloseKey(hKey) 'close the key
End If
End Function
Function EliminarLlave(Entrada As Long, Clave As String)
' Dim prueba As String
' prueba = Keyname
'Call ParseKey(Keyname, MainKeyHandle)
RegDeleteKey Entrada, Clave '<--------ruta de la clave
' Result = RegOpenKeyEx(Entrada, Clave, 0, KEY_WRITE, hKey) 'open the key
' If Result = ERROR_SUCCESS Then 'if the key could be opened then
' Result = RegDeleteKey(hKey, Clave) 'delete the key
' Result = RegCloseKey(hKey) 'close the key
' End If
End Function
Function EliminarValor(Entrada As Long, Clave As String, NomValor As String)
RegOpenKeyEx Entrada, Clave, 0, KEY_READ, hKey
RegDeleteValue hKey, NomValor
Result = RegCloseKey(hKey)
End Function
Function EscribirValorBINARIO(Entrada As Long, Clave As String, NomValor As String, Valor As String)
Dim i As Long
Result = RegOpenKeyEx(Entrada, Clave, 0, KEY_WRITE, hKey) 'abrimos la clave
If Result = ERROR_SUCCESS Then 'si no hay error al abrir la clave
lDataSize = Len(Valor)
ReDim ByteArray(lDataSize)
For i = 1 To lDataSize
ByteArray(i) = Asc(Mid$(Valor, i, 1))
Next
Result = RegSetValueExB(hKey, NomValor, 0, REG_BINARY, ByteArray(1), lDataSize) 'Escribimos el valor
If Not Result = ERROR_SUCCESS Then 'Si no hay valor al escribir
If DisplayErrorMsg = True Then 'Si esta activado la visualizacion de errores
MsgBox ErrorMsg(Result) 'visualizamos el error
End If
End If
Result = RegCloseKey(hKey) 'Cerramos la llave
Else 'Si hay error al abrir la llave
If DisplayErrorMsg = True Then 'Si esta activado la visualizacion de errores
MsgBox ErrorMsg(Result) 'visualizamos el error
End If
End If
End Function
'**************************
'FIN DEL MODULO
'**************************
El modo de uso es el siguiente:
EscribirValorDWORD HKEY_CURRENT_USER, "Software\Microsoft\Windows\CurrentVersion\Policies\System", "TuValor", "valor"
Espero te sea de ayuda.
Salu2,
Xabi.