Attribute VB_Name = "modRegistry"
' ----------------------------------------------------------------------------
'  Copyright (C) 2009 Noda (Yohan Lasorsa) - http://nodadev.wordpress.com
' ----------------------------------------------------------------------------
'  This software Is provided 'as-is', without any express or implied
'  warranty. In no event will the author be held liable for any damages
'  arising from the use of this software.
'
'  Permission is granted to anyone to use this software for any purpose,
'  including commercial applications, and to alter it and redistribute it
'  freely, subject to the following restrictions:
'
'  1. The origin of this software must not be misrepresented; you must not
'     claim that you wrote the original software. If you use this software
'     in a product, an acknowledgment in the product documentation would be
'     appreciated but is not required.
'  2. Altered source versions must be plainly marked as such, and must not be
'     misrepresented as being the original software.
'  3. This notice may not be removed or altered from any source distribution.
' ----------------------------------------------------------------------------
' Based on the Kenneth Ives RegDemo source code
' ----------------------------------------------------------------------------

Option Explicit

Private Declare Function SysRegCloseKey Lib "advapi32.dll" Alias "RegCloseKey" _
    (ByVal lRootKey As Long) As Long
  
Private Declare Function SysRegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" _
    (ByVal lRootKey As Long, ByVal sSubKey As String, phkResult As Long) As Long
  
Private Declare Function SysRegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" _
    (ByVal lRootKey As Long, ByVal sSubKey As String) As Long
  
Private Declare Function SysRegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" _
    (ByVal lRootKey As Long, ByVal sValueName As String) As Long
  
Private Declare Function SysRegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" _
    (ByVal lRootKey As Long, ByVal sSubKey As String, phkResult As Long) As Long
  
Private Declare Function SysRegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" _
    (ByVal lRootKey As Long, ByVal sValueName As String, ByVal lReserved As Long, _
    lType As Long, ByVal lpData As Any, lData As Long) As Long

Private Declare Function SysRegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" _
    (ByVal lRootKey As Long, ByVal sValueName As String, ByVal Reserved As Long, _
    ByVal lType As Long, lpData As Any, ByVal lData As Long) As Long
  
Private Const REG_NONE As Long = 0                      ' No value type
Private Const REG_SZ As Long = 1                        ' nul terminated string
Private Const REG_EXPAND_SZ As Long = 2                 ' nul terminated string w/environment var
Private Const REG_BINARY As Long = 3                    ' Free form binary
Private Const REG_DWORD As Long = 4                     ' 32-bit number
Private Const REG_DWORD_LITTLE_ENDIAN As Long = 4       ' 32-bit number (same as REG_DWORD)
Private Const REG_DWORD_BIG_ENDIAN As Long = 5          ' 32-bit number
Private Const REG_LINK As Long = 6                      ' Symbolic Link (unicode)
Private Const REG_MULTI_SZ As Long = 7                  ' Multiple Unicode strings
Private Const REG_RESOURCE_LIST As Long = 8             ' Resource list in the resource map
Private Const REG_FULL_RESOURCE_DESCRIPTOR As Long = 9  ' Resource list in the hardware description
Private Const REG_RESOURCE_REQUIREMENTS_LIST As Long = 10

Private Const KEY_QUERY_VALUE As Long = &H1
Private Const KEY_SET_VALUE As Long = &H2
Private Const KEY_CREATE_SUB_KEY As Long = &H4
Private Const KEY_ENUMERATE_SUB_KEYS As Long = &H8
Private Const KEY_NOTIFY As Long = &H10
Private Const KEY_CREATE_LINK As Long = &H20
Private Const KEY_ALL_ACCESS As Long = &H3F

Public Const HKEY_CLASSES_ROOT As Long = &H80000000
Public Const HKEY_CURRENT_USER As Long = &H80000001
Public Const HKEY_LOCAL_MACHINE As Long = &H80000002
Public Const HKEY_USERS As Long = &H80000003
Public Const HKEY_PERFORMANCE_DATA As Long = &H80000004
Public Const HKEY_CURRENT_CONFIG As Long = &H80000005
Public Const HKEY_DYN_DATA As Long = &H80000006

Private Const ERROR_SUCCESS As Long = 0
Private Const ERROR_ACCESS_DENIED As Long = 5
Private Const ERROR_NO_MORE_ITEMS As Long = 259

Private Const REG_OPTION_NON_VOLATILE As Long = 0
Private Const REG_OPTION_VOLATILE As Long = &H1

Public Function RegDeleteSubKey(ByVal lRootKey As Long, _
                                ByVal sRegKeyPath As String, _
                                ByVal sRegSubKey As String)
    Dim lKeyHandle As Long

    ' check if the key exists
    If RegDoesKeyExist(lRootKey, sRegKeyPath) Then
        Call SysRegOpenKey(lRootKey, sRegKeyPath, lKeyHandle)
        Call SysRegDeleteValue(lKeyHandle, sRegSubKey)
        Call SysRegCloseKey(lKeyHandle)
    End If
End Function

Public Function RegDoesKeyExist(ByVal lRootKey As Long, ByVal sRegKeyPath As String) As Boolean
    Dim lKeyHandle As Long
    lKeyHandle = 0
  
    Call SysRegOpenKey(lRootKey, sRegKeyPath, lKeyHandle)
    If lKeyHandle = 0 Then
        RegDoesKeyExist = False
    Else
        RegDoesKeyExist = True
    End If
    Call SysRegCloseKey(lKeyHandle)
End Function

Public Function RegQueryKey(ByVal lRootKey As Long, _
                            ByVal sRegKeyPath As String, _
                            ByVal sRegSubKey As String) As Variant
    
    Dim lRetVal As Long
    Dim iPosition As Integer
    Dim lKeyHandle As Long
    Dim lDataType As Long
    Dim lBufferSize As Long
    Dim lBuffer As Long
    Dim sBuffer As String
    lKeyHandle = 0
    lBufferSize = 0
  
    Call SysRegOpenKey(lRootKey, sRegKeyPath, lKeyHandle)
    If lKeyHandle = 0 Then
        RegQueryKey = ""
        Call SysRegCloseKey(lKeyHandle)
        Exit Function
    End If
  
    Call SysRegQueryValueEx(lKeyHandle, sRegSubKey, 0&, lDataType, ByVal 0&, lBufferSize)
  
    If lKeyHandle = 0 Then
        RegQueryKey = ""
        Call SysRegCloseKey(lKeyHandle)
        Exit Function
    End If
  
    Select Case lDataType
        Case REG_SZ, REG_MULTI_SZ, REG_EXPAND_SZ:        ' string data (most common)
            sBuffer = Space(lBufferSize)
            lRetVal = SysRegQueryValueEx(lKeyHandle, sRegSubKey, 0&, 0&, ByVal sBuffer, lBufferSize)
              
            If lRetVal <> ERROR_SUCCESS Then
                RegQueryKey = ""
            Else
                ' strip out the string data
                iPosition = InStr(1, sBuffer, Chr(0))  ' look for the first null char
                If ((lDataType = REG_SZ) And (iPosition > 0)) Then
                    ' if we found one, then save everything up to that point
                    RegQueryKey = Left(sBuffer, iPosition - 1)
                Else
                    ' did not find one, get everything.
                    RegQueryKey = sBuffer
                End If
            End If
              
        Case REG_DWORD:     ' numeric data (Integer)
            lRetVal = SysRegQueryValueEx(lKeyHandle, sRegSubKey, 0&, lDataType, lBuffer, 4&)  ' 4& = 4-byte word (long integer)
              
            If lRetVal <> ERROR_SUCCESS Then
                RegQueryKey = ""
            Else
                RegQueryKey = lBuffer
            End If
        
        Case REG_BINARY:    ' binary data (only 4 bytes binary data is supported here)
            lRetVal = SysRegQueryValueEx(lKeyHandle, sRegSubKey, 0&, lDataType, lBuffer, 4&)  ' 4& = 4-byte word (long integer)
              
            If lRetVal <> ERROR_SUCCESS Then
                RegQueryKey = ""
            Else
                RegQueryKey = lBuffer
            End If
         
        Case Else:         ' unknown
            RegQueryKey = "caca"
    End Select
  
    Call SysRegCloseKey(lKeyHandle)
End Function

Public Sub RegCreateKeyValue(ByVal lRootKey As Long, ByVal sRegKeyPath As String, _
                             ByVal sRegSubKey As String, vRegData As Variant)
    
    Dim lKeyHandle As Long
    Dim lDataType As Long
    Dim lKeyValue As Long
    Dim sKeyValue As String
  
    If IsNumeric(vRegData) Then
        lDataType = REG_DWORD
    Else
        lDataType = REG_SZ
    End If
  
    Call SysRegCreateKey(lRootKey, sRegKeyPath, lKeyHandle)
    
    Select Case lDataType
        Case REG_SZ:        ' string data
            sKeyValue = Trim(vRegData) & Chr(0)     ' null terminated
            Call SysRegSetValueEx(lKeyHandle, sRegSubKey, 0&, lDataType, ByVal sKeyValue, Len(sKeyValue))
                                   
        Case REG_DWORD:     ' numeric data
            lKeyValue = CLng(vRegData)
            Call SysRegSetValueEx(lKeyHandle, sRegSubKey, 0&, lDataType, lKeyValue, 4&)  ' 4& = 4-byte word (long integer)
    End Select
  
    Call SysRegCloseKey(lKeyHandle)
End Sub

Public Sub RegCreate4BytesBinaryKeyValue(ByVal lRootKey As Long, ByVal sRegKeyPath As String, _
                                         ByVal sRegSubKey As String, vRegData As Long)
    
    Dim lKeyHandle As Long
    Call SysRegCreateKey(lRootKey, sRegKeyPath, lKeyHandle)
    Call SysRegSetValueEx(lKeyHandle, sRegSubKey, 0&, REG_BINARY, vRegData, 4&)  ' 4& = 4-byte word (long integer)
    Call SysRegCloseKey(lKeyHandle)
End Sub

Public Function RegCreateKey(ByVal lRootKey As Long, ByVal sRegKeyPath As String)
    Dim lKeyHandle As Long
    Call SysRegCreateKey(lRootKey, sRegKeyPath, lKeyHandle)
    Call SysRegCloseKey(lKeyHandle)
End Function

Public Function RegDeleteKey(ByVal lRootKey As Long, _
                             ByVal sRegKeyPath As String, _
                             ByVal strRegKeyName As String) As Boolean
    
    Dim lKeyHandle As Long
    Dim lRetVal As Long
    RegDeleteKey = False
  
    If RegDoesKeyExist(lRootKey, sRegKeyPath) Then
        Call SysRegOpenKey(lRootKey, sRegKeyPath, lKeyHandle)
        lRetVal = SysRegDeleteKey(lKeyHandle, strRegKeyName)
        If (lRetVal = 0) Then
            RegDeleteKey = True
        End If
        Call SysRegCloseKey(lKeyHandle)
    End If
End Function
