VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "clsEasyRegistry"
Attribute VB_GlobalNameSpace = True
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit
'
' ___________________________________________________
'  Luca Minudel                    software designer
'  Italy Conegliano(TV)
'  voice & fax                     +39 (0)438 412280
'  e-mail                      luca.minudel@nline.it
'  WWW                       (italian language used)
'  http://www.geocities.com/SiliconValley/Vista/4041
'
' If you discover any bug or improvements to EasyRegistry please tell me,
' that 's why I'm sharing my work.
' I 'll correct any bug as soon as possible.
' Suggestions are welcome.
'
'
' -- Current Key
Private strCurrentDirectory As String
Private lngKeyHandle As Long
'
' --- Constants
'
'
' --- DirValue return a variant that is NULL or is an array(0 to 2).
'     These are index constants with respective meaning.
'
Public Enum enmDirValueIndex
  erValueName
  erValue
  erValueType
End Enum
'
' --- ValueOf and DirValue receive and return data types of data they are
'     managing. These are valid data type constants.
'
Public Enum enmDataType
 erSTRING
 erByte
 erDWord
End Enum
'
' --- ValueOf return an array with many rappresentations for each value.
'     These are index constants with respective meaning.
'
Public Enum enmValueOfIndex
  erStringFormat
  erByteFormat
  erDWordFormat
End Enum
'
' ------------------------------- API DEL REGISTRO -------------------------
'
Private Declare Function RegOpenKeyEx Lib "advapi32" Alias "RegOpenKeyExA" _
        (ByVal hKey As Long, ByVal lpSubKey As String, _
         ByVal ulOptions As Long, ByVal samDesired As Long, _
         phkResult As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32" (ByVal hKey As Long) As Long
Private Declare Function RegQueryInfoKey Lib "advapi32.dll" Alias "RegQueryInfoKeyA" _
        (ByVal hKey As Long, ByVal lpClass As String, _
         lpcbClass As Long, 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 Any) As Long
Private Declare Function RegEnumKeyEx Lib "advapi32.dll" Alias "RegEnumKeyExA" _
        (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, _
         lpcbName As Long, lpReserved As Long, ByVal lpClass As String, _
         lpcbClass As Long, lpftLastWriteTime As FILETIME) As Long
Private Declare Function RegEnumValue Lib "advapi32.dll" Alias "RegEnumValueA" _
        (ByVal hKey As Long, ByVal dwIndex As Long, _
         ByVal lpValueName As String, lpcbValueName As Long, _
         lpReserved As Long, lpType As Long, lpData As Any, _
         lpcbData As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32" 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
Private Declare Function RegSetValueEx Lib "advapi32" 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
Private Declare Function RegDeleteKey Lib "advapi32" Alias "RegDeleteKeyA" _
        (ByVal hKey As Long, ByVal lpSubKey As String) As Long
Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" _
        (ByVal hKey As Long, ByVal lpValueName As String) As Long
Private Declare Function RegCreateKeyEx Lib "advapi32" 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 SECURITY_ATTRIBUTES, _
         phkResult As Long, lpdwDisposition As Long) As Long

'
' ---------------------------- COSTANTI DEL REGISTRO -----------------------
'
' -- HANDLE DELLE CHIAVI PREDEFINITE
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
' -- SICUREZZA
Const READ_CONTROL = &H20000
Const SYNCHRONIZE = &H100000
Const STANDARD_RIGHTS_ALL = &H1F0000
Const STANDARD_RIGHTS_READ = READ_CONTROL
Const STANDARD_RIGHTS_WRITE = READ_CONTROL
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 KEY_ALL_ACCESS = ((STANDARD_RIGHTS_ALL Or KEY_QUERY_VALUE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY Or KEY_CREATE_LINK) And (Not SYNCHRONIZE))
Const KEY_READ = ((STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY) And (Not SYNCHRONIZE))
Const KEY_EXECUTE = ((KEY_READ) And (Not SYNCHRONIZE))
Const KEY_WRITE = ((STANDARD_RIGHTS_WRITE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY) And (Not SYNCHRONIZE))
' -- CODICI DI ERRORE RITORNATI DALLE API DI REGISTRO
Const ERROR_SUCCESS = 0&
Const ERROR_FILE_NOT_FOUND = 2&
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&
' -- TIPI DI DATO
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
' -- OPZIONI
Const REG_OPTION_NON_VOLATILE = 0&
Const REG_OPTION_VOLATILE = &H1
'
' --------------------------- TIPI DI DATO API REGISTRO --------------------
'
Private Type SECURITY_ATTRIBUTES
  nLength As Long
  lpSecurityDescriptor As Long
  bInheritHandle As Long
End Type
Private Type FILETIME
  dwLowDateTime As Long
  dwHighDateTime As Long
End Type
Private Sub Class_Initialize()
  strCurrentDirectory = ""
  lngKeyHandle = 0
End Sub
Private Sub Class_Terminate()
  ' cHIUDI TUTTE LE CHIAVI
  If strCurrentDirectory <> "" Then TestAPIError RegCloseKey(lngKeyHandle)
End Sub
'
' --------------------------- METODI/PROPRIETA' PUBBLICHE ------------------
'
Property Get CurrentKey() As String
  CurrentKey = strCurrentDirectory
End Property
Public Sub Cd(ByVal strDirectory As String)
'(ERROR ROUTINE BY-PASS) di Luca Minudel il 04/05/97 2.17.16
  On Error GoTo Cd_Err
  CdExt strDirectory, KEY_ALL_ACCESS
  Exit Sub

Cd_Err:
  Err.Raise Err.Number, Err.Source, Err.Description
End Sub

Public Function DirKey() As Variant
'(ERROR ROUTINE BY-PASS) di Luca Minudel il 04/05/97 2.17.16
Dim lngSubKeysCount As Long
Dim lngKeyLenght As Long
Dim strKeyName As String
Dim lngI As Long
Dim astrKey() As String
Dim lngMaxSubKeyLen As Long
Dim lngMaxClassLen As Long
Dim lngValues As Long
Dim udtData As FILETIME
Dim lngMaxValueNameLen As Long
Dim lngMaxValueLen As Long
Dim lngSecurityDescriptor As Long
Dim strClass As String
Dim lngClass As Long
  On Error GoTo DirKey_Err
  If CurrentKey = "" Then
    ReDim astrKey(0 To 5) As String
    astrKey(0) = "HKEY_CLASSES_ROOT"
    astrKey(1) = "HKEY_CURRENT_USER"
    astrKey(2) = "HKEY_LOCAL_MACHINE"
    astrKey(3) = "HKEY_USERS"
    astrKey(4) = "HKEY_DYN_DATA"
    astrKey(5) = "HKEY_CURRENT_CONFIG"
DirKey = astrKey
  Else
    CdExt CurrentKey, KEY_READ
    udtData.dwHighDateTime = 0
    udtData.dwLowDateTime = 0
    lngKeyLenght = 1024
    strKeyName = String$(1024, 32)
    TestAPIError RegQueryInfoKey(lngKeyHandle, _
                                 strKeyName, lngKeyLenght, ByVal 0&, _
                                 lngSubKeysCount, _
                                 lngMaxSubKeyLen, lngMaxClassLen, _
                                 lngValues, lngMaxValueNameLen, _
                                 lngMaxValueLen, lngSecurityDescriptor, _
                                 udtData)
    If lngSubKeysCount > 0 Then
      For lngI = 0 To (lngSubKeysCount - 1)
        strClass = String$(1024, 32)
        lngClass = 1024
        strKeyName = String$(1024, 32)
        lngKeyLenght = 1024
        udtData.dwHighDateTime = 0
        udtData.dwLowDateTime = 0
        TestAPIError RegEnumKeyEx(lngKeyHandle, lngI, _
                                  strKeyName, lngKeyLenght, _
                                  ByVal 0&, strClass, lngClass, udtData)
        ReDim Preserve astrKey(0 To lngI) As String
        astrKey(lngI) = Left(strKeyName, lngKeyLenght)
      Next lngI
      DirKey = astrKey
    Else
      DirKey = Null
    End If
    CdExt CurrentKey, KEY_ALL_ACCESS
  End If
  Exit Function

DirKey_Err:
  Err.Raise Err.Number, Err.Source, Err.Description
End Function
Public Function DirValue() As Variant
'(ERROR ROUTINE BY-PASS) di Luca Minudel il 04/05/97 2.17.16
Dim lngValueCount As Long
Dim strValueName As String
Dim lngValueNameLength As Long
Dim lngValueLength As Long
Dim lngValueType As Long
Dim strKeyName As String
Dim lngKeyLenght As Long
Dim lngI As Long
Dim lngJ As Long
Dim lngK As Long
Dim abytValue(1024) As Byte
Dim astrValue() As String
Dim lngTemp As Long
Dim dblTemp As Double
Dim strTemp As String
Dim lngSubKeysCount As Long
Dim lngMaxSubKeyLen As Long
Dim lngMaxClassLen As Long
Dim lngValues As Long
Dim udtData As FILETIME
Dim lngMaxValueNameLen As Long
Dim lngMaxValueLen As Long
Dim lngSecurityDescriptor As Long
On Error GoTo DirKey_Err
  If CurrentKey = "" Then
    DirValue = Null
  Else
    CdExt CurrentKey, KEY_READ
    lngKeyLenght = 1024
    strKeyName = String$(1024, 32)
    lngValueCount = 0
    udtData.dwHighDateTime = 0
    udtData.dwLowDateTime = 0
    TestAPIError RegQueryInfoKey(lngKeyHandle, _
                                 strKeyName, lngKeyLenght, ByVal 0&, _
                                 lngSubKeysCount, _
                                 lngMaxSubKeyLen, lngMaxClassLen, _
                                 lngValueCount, lngMaxValueNameLen, _
                                 lngMaxValueLen, lngSecurityDescriptor, _
                                 udtData)
    If lngValueCount > 0 Then
      For lngI = 0 To (lngValueCount - 1)
        lngValueNameLength = 1024
        strValueName = String$(1024, 32)
        lngValueLength = 1024
        abytValue(1024) = 0
        TestAPIError RegEnumValue(lngKeyHandle, lngI, _
                                  strValueName, lngValueNameLength, ByVal 0&, _
                                  lngValueType, abytValue(0), lngValueLength)
        ReDim Preserve astrValue(0 To 2, 0 To lngI) As String
        astrValue(erValueName, lngI) = Left(strValueName, lngValueNameLength)
        If lngValueLength > 0 Then
          Select Case lngValueType
            Case REG_BINARY
              lngTemp = 0
              astrValue(erValueType, lngI) = erByte
              For lngJ = 0 To lngValueLength - 1
                astrValue(erValue, lngI) = astrValue(erValue, lngI) & Hex(abytValue(lngJ)) & " "
              Next
              astrValue(erValue, lngI) = Trim(astrValue(erValue, lngI))
            Case REG_DWORD
              dblTemp = 0
              astrValue(erValueType, lngI) = erDWord
              For lngJ = 0 To lngValueLength - 1 Step 2
                dblTemp = dblTemp + (256& ^ lngJ) * abytValue(lngJ)
                dblTemp = dblTemp + (256& ^ (lngJ + 1)) * abytValue(lngJ + 1)
                strTemp = Hex(256& * abytValue(lngValueLength - 1 - lngJ) + _
                              abytValue(lngValueLength - 1 - lngJ - 1))
                astrValue(erValue, lngI) = astrValue(erValue, lngI) & _
                  String(4 - Len(strTemp), "0") & strTemp
              Next
              astrValue(erValue, lngI) = astrValue(erValue, lngI) & " (" & Format(dblTemp, "0,000,000,000") & ")"
            Case Else
              astrValue(erValueType, lngI) = erSTRING
              For lngJ = 0 To lngValueLength - 2
                astrValue(erValue, lngI) = astrValue(erValue, lngI) & Chr(abytValue(lngJ))
              Next
          End Select
          'Debug.Print astrValue(0,lngI)
          'Debug.Print astrValue(1,lngI)
          'Debug.Print astrValue(2,lngI)
        End If
      Next lngI
      DirValue = astrValue
    Else
      DirValue = Null
    End If
    CdExt CurrentKey, KEY_ALL_ACCESS
  End If
  Exit Function

DirKey_Err:
  Err.Raise Err.Number, Err.Source, Err.Description
End Function
Public Property Let ValueOf(ByVal strValueName As String, lngValueType As enmDataType, ByVal vntValue As Variant)
'(ERROR ROUTINE BY-PASS) di Luca Minudel il 18/05/97 16.35.53
Dim strData As String
Dim strDataTmp As String
Dim lngData As Long
Dim lngI As Long
Dim bytType As Byte
  On Error GoTo ValueOf_Err
   
  Select Case lngValueType
    Case erByte
      bytType = REG_BINARY
      If TypeName(vntValue) <> "Byte()" Then _
        ClassError 3
      If Dimensione(vntValue) <> 1 Then _
        ClassError 3
      lngData = UBound(vntValue) - LBound(vntValue) + 1
      strData = ""
      For lngI = LBound(vntValue) To UBound(vntValue)
        strData = strData & Chr(vntValue(lngI))
      Next
    Case erDWord
      bytType = REG_DWORD
      If TypeName(vntValue) <> "Double" Then _
        ClassError 3
      If CDbl(vntValue) <> Int(CDbl(vntValue)) Then _
        ClassError 3
      vntValue = Int(CDbl(vntValue))
      If vntValue < 0 Or vntValue > 4294967295# Then _
        ClassError 3
      vntValue = Int(CDbl(vntValue))
      ' MSB
      strDataTmp = Chr(Int(vntValue / 256 ^ 3))
      vntValue = vntValue - (256 ^ 3) * Int(vntValue / 256 ^ 3)
      '
      strDataTmp = strDataTmp & Chr(Int(vntValue / 256 ^ 2))
      vntValue = vntValue - (256 ^ 2) * Int(vntValue / 256 ^ 2)
      '
      strDataTmp = strDataTmp & Chr(Int(vntValue / 256))
      vntValue = vntValue - 256 * Int(vntValue / 256)
      ' LSB
      strDataTmp = strDataTmp & Chr(Int(vntValue))
      '
      strData = Mid(strDataTmp, 4, 1) & Mid(strDataTmp, 3, 1) & Mid(strDataTmp, 2, 1) & Mid(strDataTmp, 1, 1)
      lngData = 4
    Case erSTRING
      bytType = REG_SZ
      If TypeName(vntValue) <> "String" Then _
        ClassError 3
      strData = vntValue & Chr(0)
      lngData = Len(strData)
    Case Else
      ClassError 4
  End Select
  TestAPIError RegSetValueEx(lngKeyHandle, _
                             strValueName, 0&, _
                             bytType, strData, lngData)
  Exit Property

ValueOf_Err:
  Err.Raise Err.Number, Err.Source, Err.Description
End Property
Public Property Get ValueOf(ByVal strValueName As String, ByRef lngValueType As enmDataType) As Variant
'(ERROR ROUTINE BY-PASS) di Luca Minudel il 18/05/97 16.33.50
Dim strData As String
Dim lngData As Long
Dim lngType As Long
Dim avntData(0 To 2) As Variant
Dim abytData() As Byte
Dim strFormattedData As String
Dim dblData As Double
Dim lngJ As Long
Dim lngK As Long
Dim strTemp As String

  On Error GoTo ValueOf_Err
  If CurrentKey <> "" Then _
    CdExt CurrentKey, KEY_READ
  TestAPIError RegQueryValueEx(lngKeyHandle, _
                               strValueName, 0&, _
                               lngType, _
                               strData, lngData)
  strData = String$(lngData, 32)
  TestAPIError RegQueryValueEx(lngKeyHandle, _
                               strValueName, 0&, _
                               lngType, _
                               strData, lngData)
  Select Case lngType
    Case REG_BINARY
      lngValueType = erByte
    Case REG_DWORD
      lngValueType = erDWord
    Case Else
      lngValueType = erSTRING
  End Select
  'ReDim abytData(0 To 0) As Byte
  If lngData > 0 Then
    ReDim abytData(0 To lngData - 1) As Byte
    Select Case lngType
      Case REG_BINARY
        For lngJ = 1 To lngData
          strFormattedData = strFormattedData & _
                             Hex(Asc(Mid(strData, lngJ, 1))) & " "
          abytData(lngJ - 1) = Asc(Mid(strData, lngJ, 1))
        Next
        strFormattedData = Trim(strFormattedData)
        dblData = 0
      Case REG_DWORD
        dblData = 0
        For lngJ = 0 To lngData - 1 Step 2
          dblData = dblData + (256& ^ lngJ) * Asc(Mid(strData, lngJ + 1, 1))
          dblData = dblData + (256& ^ (lngJ + 1)) * Asc(Mid(strData, lngJ + 2, 1))
          strTemp = Hex(256& * Asc(Mid(strData, lngData - lngJ, 1)) + _
                        Asc(Mid(strData, lngData - lngJ - 1, 1)))
          strFormattedData = strFormattedData & String(4 - Len(strTemp), "0") & strTemp
          abytData(lngJ) = Asc(Mid(strData, lngJ + 1, 1))
          abytData(lngJ + 1) = Asc(Mid(strData, lngJ + 2, 1))
        Next
      Case Else
        If Mid(strData, lngData, 1) = vbNullChar Then
          lngData = lngData - 1
          strData = Left(strData, lngData)
        End If
        strFormattedData = strData
        If lngData > 0 Then
          For lngJ = 1 To lngData
            abytData(lngJ - 1) = Asc(Mid(strData, lngJ, 1))
          Next
          ReDim Preserve abytData(0 To lngData - 1) As Byte
        End If
        dblData = 0
    End Select
  End If
  If CurrentKey <> "" Then _
    CdExt CurrentKey, KEY_ALL_ACCESS
  avntData(erStringFormat) = strFormattedData
  avntData(erByteFormat) = abytData
  avntData(erDWordFormat) = dblData
  ValueOf = avntData
  Exit Property

ValueOf_Err:
  Err.Raise Err.Number, Err.Source, Err.Description
End Property
Public Sub MakeKey(ByVal strDirectory As String)
'(ERROR ROUTINE BY-PASS) di Luca Minudel il 18/05/97 22.43.29
Dim lngNewKeyHandle As Long
Dim lngMemorySpace As Long
Dim lpSecurityAttributes As SECURITY_ATTRIBUTES

  On Error GoTo MakeKey_Err
  lpSecurityAttributes.lpSecurityDescriptor = 0& ' NULL
  TestAPIError RegCreateKeyEx(lngKeyHandle, _
                              strDirectory, _
                              0&, "", REG_OPTION_NON_VOLATILE, _
                              KEY_ALL_ACCESS, _
                              lpSecurityAttributes, _
                              lngNewKeyHandle, _
                              lngMemorySpace)
                            
  
  Exit Sub

MakeKey_Err:
  Err.Raise Err.Number, Err.Source, Err.Description
End Sub
Public Sub DeleteKey(ByVal strName As String)
'(ERROR ROUTINE BY-PASS) di Luca Minudel il 18/05/97 22.44.22
  
  On Error GoTo DeleteKey_Err
  TestAPIError RegDeleteKey(lngKeyHandle, strName)
  
  Exit Sub

DeleteKey_Err:
  Err.Raise Err.Number, Err.Source, Err.Description
End Sub
Public Sub DeleteValue(ByVal strName As String)
'(ERROR ROUTINE BY-PASS) di Luca Minudel il 18/05/97 22.44.55
  On Error GoTo DeleteValue_Err
  TestAPIError RegDeleteValue(lngKeyHandle, strName)
  
  Exit Sub

DeleteValue_Err:
  Err.Raise Err.Number, Err.Source, Err.Description
End Sub
'
' --------------------------------------------------------------------------
'
Private Sub CdExt(ByVal strDirectory As String, ByVal lngSecurity As Long)
'(ERROR ROUTINE BY-PASS) di Luca Minudel il 03/05/97 23.56.39
Dim lngNewKeyHandle As Long
Dim lngPos As Long
  On Error GoTo CdExt_Err
  strDirectory = Trim(UCase(strDirectory))
  Select Case strDirectory
    Case "\"
      If strCurrentDirectory <> "" Then _
        TestAPIError RegCloseKey(lngKeyHandle)
      strCurrentDirectory = ""
      lngKeyHandle = 0
    Case ".."
      If strCurrentDirectory = "" Then ClassError 1
      lngPos = 1
      Do While InStr(lngPos, strCurrentDirectory, "\") > 0
        lngPos = InStr(lngPos, strCurrentDirectory, "\") + 1
      Loop
      CdExt Mid(strCurrentDirectory, 1, lngPos - 1), lngSecurity
    Case Else ' CdExt <path>
      ' Tolgo l'ultimo carattere "\" (CLS\ => CLS)
      If Right(strDirectory, 1) = "\" And Len(strDirectory) > 1 Then _
        strDirectory = Mid(strDirectory, 1, Len(strDirectory) - 1)
      ' Se manca aggiungo il simbolo di Root "\"
      If strCurrentDirectory = "" And Left(strDirectory, 1) <> "\" Then _
        strDirectory = "\" & strDirectory
      If Left(strDirectory, 1) = "\" Then ' Percorso dalla radice
        If strCurrentDirectory <> "" Then TestAPIError RegCloseKey(lngKeyHandle)
        Select Case strRoot(strDirectory)
          Case "HKEY_CLASSES_ROOT"
            lngKeyHandle = HKEY_CLASSES_ROOT
          Case "HKEY_CURRENT_USER"
            lngKeyHandle = HKEY_CURRENT_USER
          Case "HKEY_LOCAL_MACHINE"
            lngKeyHandle = HKEY_LOCAL_MACHINE
          Case "HKEY_USERS"
            lngKeyHandle = HKEY_USERS
          Case "HKEY_DYN_DATA"
            lngKeyHandle = HKEY_DYN_DATA
          Case "HKEY_CURRENT_CONFIG"
            lngKeyHandle = HKEY_CURRENT_CONFIG
          Case Else
            ClassError 2
        End Select
        strCurrentDirectory = strDirectory
        TestAPIError _
          RegOpenKeyEx _
          (lngKeyHandle, strPath(strCurrentDirectory), 0, lngSecurity, lngNewKeyHandle)
        lngKeyHandle = lngNewKeyHandle
      Else ' Percorso dalla posizione corrente
        'If strCurrentDirectory = "" Then ClassError 1
        strCurrentDirectory = strCurrentDirectory & "\" & strDirectory
        TestAPIError _
          RegOpenKeyEx _
          (lngKeyHandle, strDirectory, 0, lngSecurity, lngNewKeyHandle)
        lngKeyHandle = lngNewKeyHandle
      End If
  End Select
  'Debug.Print strCurrentDirectory, lngKeyHandle
  Exit Sub

CdExt_Err:
  Err.Raise Err.Number, Err.Source, Err.Description
End Sub
Private Function strRoot(ByVal strDirectory As String) As String
'(ERROR ROUTINE BY-PASS) di Luca Minudel il 04/05/97 15.52.08
  On Error GoTo strRoot_Err
  ' Precondition : Mid(strDirectory,1,1)="\"
  If InStr(2, strDirectory, "\") <> 0 Then
    strRoot = Mid(strDirectory, 2, InStr(2, strDirectory, "\") - 2)
  Else
    strRoot = Mid(strDirectory, 2)
  End If
  Exit Function

strRoot_Err:
  Err.Raise Err.Number, Err.Source, Err.Description
End Function
Private Function strPath(ByVal strDirectory As String) As String
'(ERROR ROUTINE BY-PASS) di Luca Minudel il 04/05/97 15.54.20
  On Error GoTo strPath_Err
  If InStr(2, strDirectory, "\") <> 0 Then
    strPath = Mid(strDirectory, InStr(2, strDirectory, "\") + 1)
  Else
    strPath = ""
  End If
  Exit Function

strPath_Err:
  Err.Raise Err.Number, Err.Source, Err.Description
End Function
Private Function Dimensione(ByRef vntMatrice As Variant) As Integer
Dim intContaDimensione As Integer
Dim intNiente As Integer
  intContaDimensione = 0
  On Error GoTo intDimensione_Fine
  Do
    intNiente = UBound(vntMatrice, intContaDimensione + 1)
    intContaDimensione = intContaDimensione + 1
  Loop
intDimensione_Fine:
  Dimensione = intContaDimensione
End Function
Private Sub ClassError(ByVal lngNumber As Long)
  Err.Source = "EasyRegistry"
  Select Case lngNumber
    Case 1
      Err.Description = "No current Key."
    Case 2
      Err.Description = "Invalid Key root."
    Case 3
      Err.Source = Err.Source & " [Let ValueOf]"
      Err.Description = "Type passed doesn't match Value passed."
    Case 4
      Err.Source = Err.Source & " [Let ValueOf]"
      Err.Description = "Type passed doesn't exist. Use STRING, DWORD or BINARY."
    Case Else
      Err.Description = "Undefined error number : " & CStr(vbObject + lngNumber)
      lngNumber = 255
  End Select
  Err.Raise vbObjectError + lngNumber
End Sub
Private Sub TestAPIError(ByVal lngNumber As Long)
  Err.Source = "EasyRegistry[API Call]"
  Select Case lngNumber
    Case ERROR_SUCCESS
      ' Ok !
    Case ERROR_BADDB
      Err.Description = "Corrupt Registry Database!"
    Case ERROR_BADKEY
      Err.Description = "Key name is bad."
    Case ERROR_CANTOPEN
      Err.Description = "Cannot Open Key."
    Case ERROR_CANTREAD
      Err.Description = "Cannot Read Key."
    Case ERROR_CANTWRITE
      Err.Description = "Cannot Write Key."
    Case ERROR_ACCESS_DENIED
      Err.Description = "Access to Registry Denied."
    Case ERROR_OUTOFMEMORY
      Err.Description = "Out of memory."
    Case ERROR_INVALID_PARAMETER
      Err.Description = "Invalid Parameter."
    Case ERROR_FILE_NOT_FOUND
      Err.Description = "Key/Value does not exist."
    Case Else
      Err.Description = "Undefined key error code!"
  End Select
  If lngNumber = ERROR_SUCCESS Then
    Err.Clear
  Else
    Err.Raise vbObjectError + 256
  End If
End Sub
