### http://www.lawebdelprogramador.com ###
### respuesta a la pregunta 53272 de Visual Basic ###


Option Explicit
Public 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
Public 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
Public Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Public Declare Function RegCreateKeyEx Lib "advapi32.dll" Alias "RegCreateKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal Reserved As Long, ByVal lpClass As Long, ByVal dwOptions As Long, ByVal samDesired As Long, ByVal lpSecurityAttributes As Long, phkResult As Long, lpdwDisposition As Long) As Long
Public 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
Public Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long

Public Declare Function GetVolumeInformation& Lib "kernel32" Alias "GetVolumeInformationA" (ByVal lpRootPathName As String, ByVal pVolumeNameBuffer As String, ByVal nVolumeNameSize As Long, lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long)

Public Const REG_OPENED_EXISTING_KEY = &H2

Public Const REG_BINARY = 3
Public Const REG_DWORD = 4
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public Const REG_SZ = 1
Const READ_CONTROL = &H20000
Const SYNCHRONIZE = &H100000
Const STANDARD_RIGHTS_WRITE = (READ_CONTROL)
Const KEY_SET_VALUE = &H2
Const KEY_CREATE_SUB_KEY = &H4
Const KEY_QUERY_VALUE = &H1
Const KEY_ENUMERATE_SUB_KEYS = &H8
Const KEY_NOTIFY = &H10
Const KEY_READ = ((READ_CONTROL Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY) And (Not SYNCHRONIZE))
Const KEY_WRITE = ((STANDARD_RIGHTS_WRITE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY) And (Not SYNCHRONIZE))
Dim g2 As Long, g1 As Long, g3 As Long

Function GetRegistryValue(ByVal hKey As Long, ByVal KeyName As String, _
    ByVal ValueName As String, ByVal KeyType As Integer, _
    Optional DefaultValue As Variant = Empty) As Variant
' Llegeix un valor del Registre.
' Utilitzar KeyName = "" per al valor predeterminado.
' Suporta només els tipus de valors DWORD, SZ y BINARY.

    Dim handle As Long, resLong As Long
    Dim resString As String, length As Long
    Dim resBinary() As Byte
    
    ' Preparar el resultado predeterminado.
    GetRegistryValue = DefaultValue
    ' Abrir la clave, salir si no se encuentra.
    If RegOpenKeyEx(hKey, KeyName, 0, KEY_READ, handle) Then Exit Function
    
    Select Case KeyType
        Case REG_DWORD
            ' Leer el valor, utilizar el valor predeterminado si no se encuentra.
            If RegQueryValueEx(handle, ValueName, 0, REG_DWORD, _
                resLong, 4) = 0 Then
                GetRegistryValue = resLong
            End If
        Case REG_SZ
            length = 1024: resString = Space$(length)
            If RegQueryValueEx(handle, ValueName, 0, REG_SZ, _
                ByVal resString, length) = 0 Then
                ' Si se encuentra el valor, eliminar los caracteres sobrantes.
                GetRegistryValue = Left$(resString, length - 1)
            End If
        Case REG_BINARY
            length = 4096
            ReDim resBinary(length - 1) As Byte
            If RegQueryValueEx(handle, ValueName, 0, REG_BINARY, _
                resBinary(0), length) = 0 Then
                ReDim Preserve resBinary(length - 1) As Byte
                GetRegistryValue = resBinary()
            End If
        Case Else
            Err.Raise 1001, , "Tipus de valor no compatible"
    End Select
    
    RegCloseKey handle
End Function

' Crear una clave en el Registro, a continuación, cerrarla.
' Devolver True si la clave ya existe, False si fue creada.

Function CreateRegistryKey(ByVal hKey As Long, ByVal KeyName As String) As Boolean
    Dim handle As Long, disposition As Long
    
    CreateRegistryKey = True
    
    If RegCreateKeyEx(hKey, KeyName, 0, 0, 0, 0, 0, handle, disposition) Then
        'Err.Raise 1001, , "No fue posible crear la clave del registro"
    Else
        ' Devolver True si la clave ya existe.
        CreateRegistryKey = (disposition = REG_OPENED_EXISTING_KEY)
        ' Cerrar la clave.
        RegCloseKey handle
    End If
End Function

' Escribir o crear un valor en el Registro.
' Utilizar KeyName = "" para el valor predeterminado.
' Sólo soporta los tipos de valores DWORD, SZ y BINARY.

Public Sub SetRegistryValue(ByVal hKey As Long, ByVal KeyName As String, ByVal ValueName As String, ByVal KeyType As Integer, value As Variant)
    Dim handle As Long, lngValue As Long
    Dim strValue As String
    Dim binValue() As Byte, length As Long
    
    ' Abrir la clave, salir si no se encuentra.
    If RegOpenKeyEx(hKey, KeyName, 0, KEY_WRITE, handle) Then
        MsgBox "No s'ha trobat la clau en el Registre"
        Exit Sub
    End If
    
    Select Case KeyType
        Case REG_DWORD
            lngValue = value
            RegSetValueEx handle, ValueName, 0, KeyType, lngValue, 4
        Case REG_SZ
            strValue = value
            RegSetValueEx handle, ValueName, 0, KeyType, ByVal strValue, Len(strValue)
        Case REG_BINARY
            binValue = value
            length = UBound(binValue) - LBound(binValue) + 1
            RegSetValueEx handle, ValueName, 0, KeyType, binValue(LBound(binValue)), length
    End Select
    
    ' Cerrar la clave.
    RegCloseKey handle
    
End Sub

' Borrar un valor.

Sub DeleteRegistryValue(ByVal hKey As Long, ByVal KeyName As String, ByVal ValueName As String)
    Dim handle As Long
    
    ' Abrir la clave, salir si no se encuentra.
    If RegOpenKeyEx(hKey, KeyName, 0, KEY_WRITE, handle) Then Exit Sub
    ' Borrar el valor.
    RegDeleteValue handle, ValueName
    ' Cerrar el manejador.
    RegCloseKey handle
    
End Sub

' Comprobar si existe una determinada clave en el Registro.

Function CheckRegistryKey(ByVal hKey As Long, ByVal KeyName As String) As Boolean
    Dim handle As Long
    ' Intentar abrir la clave.
    If RegOpenKeyEx(hKey, KeyName, 0, KEY_READ, handle) = 0 Then
        ' La clave existe.
        CheckRegistryKey = True
        ' Cerrarla antes de salir.
        RegCloseKey handle
    End If
    
End Function
''''''''''''''''''''''''''''''''''''''''''''''''

### danyboy pvttrevor@gmail.com ###