Attribute VB_Name = "modReg"
' -------------------------------------------------------------------------------
'
'   AVStoDVD - by MrC
'   File: modReg.bas
'   Purpose: Windows Registry functions and utils
'
' -------------------------------------------------------------------------------


Option Explicit
Option Compare Binary
Option Base 0

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

Private Const REG_OPTION_NON_VOLATILE = 0&

Private Const KEY_QUERY_VALUE = &H1
Private Const KEY_SET_VALUE = &H2
Private Const KEY_CREATE_SUB_KEY = &H4
Private Const KEY_ENUMERATE_SUB_KEYS = &H8
Private Const KEY_NOTIFY = &H10
Private Const KEY_CREATE_LINK = &H20
Private Const KEY_ALL_ACCESS = &H3F
Private Const KEY_READ = &H20019
Private Const KEY_WRITE = &H20006

Private Const ERROR_SUCCESS = 0&
Private Const REG_SZ = 1&
Private Const REG_EXPAND_SZ = 2&
Private Const REG_BINARY = 3&
Private Const REG_DWORD = 4&

Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type

Declare Function RegCreateKeyEx Lib "advapi32.dll" 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, lpSecurityAttributes As Long, phkResult As Long, lpdwDisposition As Long) As Long
Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
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 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
      'Note that if you declare the lpData parameter as String, you must pass it ByVal.
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
      'Note that if you declare the lpData parameter as String, you must pass it ByVal.
Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long
Declare Function RegQueryInfoKey Lib "advapi32.dll" Alias "RegQueryInfoKeyA" (ByVal hKey As Long, ByVal lpClass As String, lpcbClass As Long, ByVal lpReserved As Long, lpcSubKeys As Long, lpcbMaxSubKeyLen As Long, lpcbMaxClassLen As Long, lpcValues As Long, lpcbMaxValueNameLen As Long, lpcbMaxValueLen As Long, lpcbSecurityDescriptor As Long, lpftLastWriteTime As FILETIME) As Long
Declare Function RegEnumKeyEx Lib "advapi32.dll" Alias "RegEnumKeyExA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, lpcbName As Long, ByVal lpReserved As Long, ByVal lpClass As String, lpcbClass As Long, lpftLastWriteTime As FILETIME) As Long

' Output code related to main tree key
Private Function TrovaBase(ByRef Nome As String) As Long

   Dim Base As String

   Base = UCase$(Left$(Nome, InStr(Nome, "\") - 1))
   Nome = Mid$(Nome, InStr(Nome, "\") + 1)
   Select Case Base
   Case "HKEY_CLASSES_ROOT": TrovaBase = HKEY_CLASSES_ROOT
   Case "HKEY_CURRENT_USER": TrovaBase = HKEY_CURRENT_USER
   Case "HKEY_LOCAL_MACHINE": TrovaBase = HKEY_LOCAL_MACHINE
   Case "HKEY_USERS": TrovaBase = HKEY_USERS
   Case "HKEY_PERFORMANCE_DATA": TrovaBase = HKEY_PERFORMANCE_DATA
   Case "HKEY_CURRENT_CONFIG": TrovaBase = HKEY_CURRENT_CONFIG
   Case "HKEY_DYN_DATA": TrovaBase = HKEY_DYN_DATA
   Case Else: TrovaBase = &H88888888   'Valore non valido
   End Select

End Function


' Create (or open if existing) a new key and set value
Public Function CreaChiave(ByVal Nome As String) As Boolean

   Dim Chiave As Long
   Dim Base As Long
   Dim Ris As Long

   On Error GoTo Err_Handling
   
   Base = TrovaBase(Nome)
   CreaChiave = (RegCreateKeyEx(Base, Nome, 0&, vbNullString, REG_OPTION_NON_VOLATILE, KEY_QUERY_VALUE, ByVal 0&, Chiave, Ris) = ERROR_SUCCESS)
   If CreaChiave Then CreaChiave = ChiudiChiave(Chiave)

   Exit Function
   
Err_Handling:
CreaChiave = False

End Function


' Erase a key
Public Function CancellaChiave(ByVal Nome As String) As Boolean

    Dim Base As Long

    On Error GoTo Err_Handling
   
    Base = TrovaBase(Nome)
    CancellaChiave = (RegDeleteKey(Base, Nome) = ERROR_SUCCESS)
   
    Exit Function
   
Err_Handling:
CancellaChiave = False

End Function


' Open a key and set value
Private Function ApriChiave(ByVal Nome As String, ByRef hChiave As Long, ByVal Accesso As Long) As Boolean

    Dim Base As Long

    Base = TrovaBase(Nome)
    ApriChiave = (RegOpenKeyEx(Base, Nome, 0&, Accesso, hChiave) = ERROR_SUCCESS)

End Function


' Close a key
Private Function ChiudiChiave(ByVal hChiave As Long) As Boolean

    ChiudiChiave = (RegCloseKey(hChiave) = ERROR_SUCCESS)

End Function


' Verify a string from the specified key, if fails returns default value
Public Function LeggiChiaveStringa(ByVal Chiave As String, ByVal Nome As String, ByRef Valore As String, Optional ByVal Default As String = "") As Boolean

   Dim hChiave As Long
   Dim Dimensione As Long
   Dim Tipo As Long

   LeggiChiaveStringa = False
   If ApriChiave(Chiave, hChiave, KEY_QUERY_VALUE) Then
      If (RegQueryValueEx(hChiave, Nome, 0&, Tipo, ByVal 0&, Dimensione) = ERROR_SUCCESS) And (Tipo = REG_SZ) Then
         Valore = Space$(Dimensione)
         If RegQueryValueEx(hChiave, Nome, 0&, ByVal 0&, ByVal Valore, Dimensione) = ERROR_SUCCESS Then
            Valore = Left$(Valore, InStr(Valore, Chr(0)) - 1)
            LeggiChiaveStringa = True
         End If
      End If
      ChiudiChiave hChiave
   End If
   If Not LeggiChiaveStringa Then Valore = Default

End Function


' Read a string from the specified key, if fails returns default value
Public Function EmiLeggiChiaveStringa(ByVal Chiave As String, ByVal Nome As String, Optional Default As String) As String

   Dim hChiave As Long
   Dim Dimensione As Long
   Dim Tipo As Long
   Dim Valore As String

   On Error GoTo Err_Handling
   
   EmiLeggiChiaveStringa = Default
   If ApriChiave(Chiave, hChiave, KEY_QUERY_VALUE) Then
      If (RegQueryValueEx(hChiave, Nome, 0&, Tipo, ByVal 0&, Dimensione) = ERROR_SUCCESS) Then
         If (Tipo = REG_SZ) Or (Tipo = REG_EXPAND_SZ) Then
            Valore = Space$(Dimensione)
            If RegQueryValueEx(hChiave, Nome, 0&, ByVal 0&, ByVal Valore, Dimensione) = ERROR_SUCCESS Then
               Valore = Left$(Valore, InStr(Valore, Chr(0)) - 1)
               EmiLeggiChiaveStringa = Valore
            End If
         End If
      End If
      ChiudiChiave hChiave
   End If
   
   Exit Function
   
Err_Handling:
EmiLeggiChiaveStringa = Default
   
End Function


' Verify a number from the specified key, if fails returns default value
Public Function LeggiChiaveNumero(ByVal Chiave As String, ByVal Nome As String, ByRef Valore As Long, Optional ByVal Default As Long = 0) As Boolean

   Dim hChiave As Long
   Dim Tipo As Long

   LeggiChiaveNumero = False
   If ApriChiave(Chiave, hChiave, KEY_QUERY_VALUE) Then
      LeggiChiaveNumero = ((RegQueryValueEx(hChiave, Nome, 0&, Tipo, Valore, 4) = ERROR_SUCCESS) And (Tipo = REG_DWORD))
      ChiudiChiave hChiave
   End If
   If Not LeggiChiaveNumero Then Valore = Default

End Function


' Read a number from the specified key, if fails returns default value
Public Function EmiLeggiChiaveNumero(ByVal Chiave As String, ByVal Nome As String, Optional ByVal Default As Long = 0) As Long

    Dim hChiave As Long
    Dim Tipo As Long
    Dim Valore As Long

    On Error GoTo Err_Handling

    EmiLeggiChiaveNumero = Default
    If ApriChiave(Chiave, hChiave, KEY_QUERY_VALUE) Then
        If ((RegQueryValueEx(hChiave, Nome, 0&, Tipo, Valore, 4) = ERROR_SUCCESS) And (Tipo = REG_DWORD)) Then
            EmiLeggiChiaveNumero = Valore
        End If
        ChiudiChiave hChiave
    End If
    
    Exit Function
    
Err_Handling:
EmiLeggiChiaveNumero = Default

End Function


' Verify a binary from the specified key, if fails returns default value
Public Function LeggiChiaveBinario(ByVal Chiave As String, ByVal Nome As String, ByRef Valore() As Byte) As Boolean

   Dim hChiave As Long
   Dim Dimensione As Long
   Dim Tipo As Long

   LeggiChiaveBinario = False
   If ApriChiave(Chiave, hChiave, KEY_QUERY_VALUE) Then
      If (RegQueryValueEx(hChiave, Nome, 0&, Tipo, ByVal 0&, Dimensione) = ERROR_SUCCESS) And (Tipo = REG_BINARY) Then
         ReDim Valore(0 To Dimensione - 1)
         LeggiChiaveBinario = (RegQueryValueEx(hChiave, Nome, 0&, ByVal 0&, Valore(0), Dimensione) = ERROR_SUCCESS)
      End If
      ChiudiChiave hChiave
   End If

End Function


' Write a string into the specified key
Public Function ScriviChiaveStringa(ByVal Chiave As String, ByVal Nome As String, ByVal Valore As String) As Boolean

   Dim hChiave As Long

   ScriviChiaveStringa = False
   If ApriChiave(Chiave, hChiave, KEY_SET_VALUE) Then
      ScriviChiaveStringa = (RegSetValueEx(hChiave, Nome, 0&, REG_SZ, ByVal Valore, LenB(StrConv(Valore, vbFromUnicode)) + 1) = ERROR_SUCCESS)
      ChiudiChiave hChiave
   End If

End Function


' Write a binary into the specified key
Public Function ScriviChiaveBinario(ByVal Chiave As String, ByVal Nome As String, ByRef Valore() As Byte) As Boolean

   Dim hChiave As Long
   Dim Dimensione As Long

   ScriviChiaveBinario = False
   If ApriChiave(Chiave, hChiave, KEY_SET_VALUE) Then
      Dimensione = UBound(Valore) - LBound(Valore) + 1
      ScriviChiaveBinario = (RegSetValueEx(hChiave, Nome, 0&, REG_BINARY, Valore(0), Dimensione) = ERROR_SUCCESS)
      ChiudiChiave hChiave
   End If

End Function


' Write a number into the specified key
Public Function ScriviChiaveNumero(ByVal Chiave As String, ByVal Nome As String, ByVal Valore As Long) As Boolean

    Dim hChiave As Long

    On Error GoTo Err_Handling
   
    ScriviChiaveNumero = False
    If ApriChiave(Chiave, hChiave, KEY_SET_VALUE) Then
        ScriviChiaveNumero = (RegSetValueEx(hChiave, Nome, 0&, REG_DWORD, Valore, 4) = ERROR_SUCCESS)
        ChiudiChiave hChiave
    End If
    
    Exit Function
    
Err_Handling:
ScriviChiaveNumero = False

End Function


' Delete a string/number value from a key
Public Function CancellaValore(ByVal Chiave As String, ByVal Nome As String) As Boolean

    Dim hChiave As Long

    On Error GoTo Err_Handling
   
    CancellaValore = False
    If ApriChiave(Chiave, hChiave, KEY_SET_VALUE) Then
        CancellaValore = (RegDeleteValue(hChiave, Nome) = ERROR_SUCCESS)
        ChiudiChiave hChiave
    End If
    
    Exit Function
    
Err_Handling:
CancellaValore = False

End Function


' Returns a string of SubKeys names separated by ";"
Public Function SubKeysArray(ByVal Key As String) As String

    Dim hKey As Long
    Dim Base As Long
    Dim lResult As Long
    Dim lNumKeys As Long             ' Number of subkeys of open key
    Dim lSubkeyNameLen As Long       ' Length of the longest subkey name
    Dim ft As FILETIME
    Dim lCtr As Long
    Dim sBuffer As String
    Dim lBuffer As Long

    On Error GoTo Err_Handling

    If ApriChiave(Key, hKey, KEY_QUERY_VALUE) Then
        Base = TrovaBase(Key)
        ' Get subkey information
        If RegOpenKeyEx(Base, Key, 0, KEY_READ, hKey) = ERROR_SUCCESS Then
            lResult = RegQueryInfoKey(hKey, vbNullString, 0, 0, lNumKeys, lSubkeyNameLen, 0, 0, 0, 0, 0, ft)
            If lResult = ERROR_SUCCESS Then
                ' Loop as many times as there are subkeys
                For lCtr = 0 To lNumKeys - 1
                    ' Initialize buffer to hold name to be 1 greater than maximum length
                    sBuffer = Space(lSubkeyNameLen) & Chr(0)
                    lBuffer = Len(sBuffer)
                    RegEnumKeyEx hKey, lCtr, sBuffer, lBuffer, 0, vbNullString, 0, ft
                    ' Trim returned buffer to extract key name
                    sBuffer = Left(sBuffer, lBuffer)
                    SubKeysArray = SubKeysArray & sBuffer & ";"
                Next lCtr
            End If
            RegCloseKey hKey
            If Len(SubKeysArray) > 0 And Right(SubKeysArray, 1) = ";" Then
                SubKeysArray = Left(SubKeysArray, Len(SubKeysArray) - 1)
            End If
        End If
    End If
    
    Exit Function
    
Err_Handling:
SubKeysArray = ""

End Function

