Il Gestore del Registro

Da Windows 95 in poi, il Registro rappresenta una funzionalità con un grande potenziale e contemporaneamente una nuova serie di problemi da risolvere.

La classe ETRegistry incapsula le principali API fornite da Microsoft per interagire con il Registro di Systema e consente di utilizzarlo in modo abbastanza semplice.
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "ETRegistry"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
'**************************************************************
'* ETLib4VB - Easy Target Library for Visual Basic            *
'* (C) 2003 By Andrea Molino                                  *
'* Class As ETRegistry                                        *
'**************************************************************

Option Explicit

Private Const BASE_ERROR_NUM = 1000
Private Const ETErrRegCantReadData = 61
Private Const ETErrRegGetDataFailed = 62
Private Const ETErrRegSetDataFailed = 63
Private Const ETErrRegCreateKFailed = 64
Private Const ETErrRegInvalidData = 65
Private Const ETErrCantGetPrivInfo = 71


Const SYNCHRONIZE = &H100000
Const READ_CONTROL = &H20000

Const STANDARD_RIGHTS_READ = (READ_CONTROL)
Const STANDARD_RIGHTS_WRITE = (READ_CONTROL)
Const STANDARD_RIGHTS_ALL = &H1F0000

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_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))
Const KEY_EXECUTE = KEY_READ And Not SYNCHRONIZE
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 ERROR_SUCCESS = 0&

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

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 REG_CREATED_NEW_KEY = &H1
Const REG_OPENED_EXISTING_KEY = &H2
  
Const REG_OPTION_NON_VOLATILE = &H0
Const REG_OPTION_VOLATILE = &H1


Private Declare Function RegConnectRegistry Lib "advapi32.dll" Alias "RegConnectRegistryA" (ByVal lpSubKey As String, ByVal hKey As Long, phkResult As Long) As Long
Private 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
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegFlushKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private 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
Private 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
Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
Private 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
Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long
Private Declare Function RegLoadKey Lib "advapi32.dll" Alias "RegLoadKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal lpFile As String) As Long
Private Declare Function RegUnLoadKey Lib "advapi32.dll" Alias "RegUnLoadKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
Private Declare Function RegSaveKey Lib "advapi32.dll" Alias "RegSaveKeyA" (ByVal hKey As Long, ByVal lpFile As String, ByVal lpSecurityAttributes As Long) As Long
Private Declare Function RegRestoreKey Lib "advapi32.dll" Alias "RegRestoreKeyA" (ByVal hKey As Long, ByVal lpFile As String, ByVal dwFlags As Long) As Long
Private Declare Function RegEnumValue Lib "advapi32.dll" Alias "RegEnumValueA" (ByVal hKey As Long, ByVal dwIndex As Long, lpValueName As Any, lpcbValueName As Long, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
Private Declare Function RegEnumKeyEx Lib "advapi32.dll" Alias "RegEnumKeyExA" (ByVal hKey As Long, ByVal dwIndex As Long, lpName As Any, lpcbName As Long, ByVal lpReserved As Long, lpClass As Any, lpcbClass As Long, lpftLastWriteTime As FILETIME) As Long
Private Declare Function RegQueryInfoKey Lib "advapi32.dll" Alias "RegQueryInfoKeyA" (ByVal hKey As Long, ByVal lpSubKey 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, ByVal lpcbSecurityDescriptor As Long, lpftLastWriteTime As FILETIME) As Long

Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (dest As Any, Source As Any, ByVal dwBytes As Long)
Private Declare Sub ZeroMemory Lib "kernel32" Alias "RtlZeroMemory" (dest As Any, ByVal dwBytes As Long)


Private Type FILETIME
  dwLowDateTime As Long
  dwHighDateTime As Long
End Type

Private Type RegKeyInfo
  NumSubKeys As Long
  MaxSubKeyLen As Long
  NumValues As Long
  MaxValueLen As Long
  MaxDataLen As Long
  FILETIME As FILETIME
End Type

Public Enum ETRegDataType
  rdUnknown = -1
  rdNone = REG_NONE
  rdString = REG_SZ
  rdExpandString = REG_EXPAND_SZ
  rdInteger = REG_DWORD
  rdBinary = REG_BINARY
  rdMultiString = REG_MULTI_SZ
End Enum

Private Type RegDataInfo
  RegData As ETRegDataType
  DataSize As Long
End Type


Public Enum ETRegistryKey
  rkClassesRoot = HKEY_CLASSES_ROOT
  rkCurrentUser = HKEY_CURRENT_USER
  rkLocalMachine = HKEY_LOCAL_MACHINE
  rkUsers = HKEY_USERS
  rkPerformanceData = HKEY_PERFORMANCE_DATA
  rkCurrentConfig = HKEY_CURRENT_CONFIG
  rkDynData = HKEY_DYN_DATA
End Enum

Private FCurrentKey As ETRegistryKey
Private FRootKey As ETRegistryKey
Private FLazyWrite As Boolean
Private FCurrentPath As String
Private FCloseRootKey As Boolean
Private FAccess As Long

Private AuxByt As Byte
Private AuxInt As Integer
Private AuxLng As Long
Private AuxSng As Single
Private AuxDbl As Double
Private AuxCur As Currency
Private AuxDat As Date
Private AuxBoo As Boolean
Private AuxDec As Boolean
Private AuxStr As String


Private Sub Class_Initialize()
  RootKey = HKEY_CURRENT_USER
  FAccess = KEY_ALL_ACCESS
  LazyWrite = True
End Sub

Private Sub Class_Terminate()
  CloseKey
End Sub

Private Sub RaiseError(ETErr As Long, Optional MethodName As String = "", Optional Parm As Variant, Optional MoreDesc As String = "")
Dim Dsc As String
Dim ETErrDesc As String

  Select Case ETErr
    Case ETErrRegCantReadData:  ETErrDesc = "Unable to Read Data"
    Case ETErrRegGetDataFailed: ETErrDesc = "Failed to Get Data"
    Case ETErrRegSetDataFailed: ETErrDesc = "Failed to Set Data"
    Case ETErrRegCreateKFailed: ETErrDesc = "Failed to create a new Key"
    Case ETErrRegInvalidData:   ETErrDesc = "Invalid Data Type"
  End Select
  
  Dsc = "ETRegistry"
  If MethodName <> "" Then Dsc = Dsc & "." & MethodName
  Dsc = Dsc & " - " & ETErrDesc
  If Not IsMissing(Parm) Then Dsc = Dsc & " [" & Parm & "]"
  If MoreDesc <> "" Then Dsc = Dsc & vbCrLf & MoreDesc
  Err.Raise BASE_ERROR_NUM + ETErr, , Dsc, "", 0
End Sub

Private Function IsRelative(ByVal Value As String) As Boolean
  IsRelative = Not ((Value <> "") And (Mid$(Value, 1, 1) = "\"))
End Function

Private Sub SetRootKey(ByVal Value As Long)
  If FRootKey <> Value Then
    If FCloseRootKey Then
      RegCloseKey RootKey
      FCloseRootKey = False
    End If
    FRootKey = Value
    CloseKey
  End If
End Sub

Private Sub SetCurrentKey(ByVal Value As Long)
  FCurrentKey = Value
End Sub
    
Private Sub ChangeKey(ByVal Value As Long, ByVal Path As String)
  CloseKey
  FCurrentKey = Value
  FCurrentPath = Path
End Sub

Private Function GetBaseKey(ByVal Relative As Boolean) As Long
  If (FCurrentKey = 0) Or Not Relative Then
    GetBaseKey = FRootKey
  Else
    GetBaseKey = FCurrentKey
  End If
End Function

Private Function GetKey(ByVal Key As String) As Long
Dim S As String
Dim Relative As Boolean
Dim Res As Long

  S = Key
  Relative = IsRelative(S)
  If Not Relative Then S = Mid$(S, 2)
  Res = 0
  RegOpenKeyEx GetBaseKey(Relative), S, 0, FAccess, Res
  GetKey = Res
End Function

Private Function GetData(ByVal VName As String, Buffer As Byte, ByVal BufSize As Long, ByRef RegData As ETRegDataType) As Long
Dim DataType As Long
  
  DataType = REG_NONE
  If RegQueryValueEx(FCurrentKey, VName, 0, DataType, Buffer, BufSize) <> ERROR_SUCCESS Then
    RaiseError ETErrRegGetDataFailed, "GetData", VName
  End If
  GetData = BufSize
  RegData = DataType
End Function

Private Sub PutData(ByVal VName As String, Buffer As Byte, ByVal BufSize As Long, ByVal RegData As ETRegDataType)
Dim DataType As Long
  
  DataType = RegData
  If RegSetValueEx(FCurrentKey, VName, 0, DataType, Buffer, BufSize) <> ERROR_SUCCESS Then
    RaiseError ETErrRegSetDataFailed, "PutData", VName
  End If
End Sub

Private Function GetDataInfo(ByVal ValueName As String, ByRef Value As RegDataInfo) As Boolean
Dim DataType As Long
  
  ZeroMemory Value, LenB(Value) 'ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long
  GetDataInfo = RegQueryValueEx(FCurrentKey, ValueName, 0, DataType, ByVal 0, Value.DataSize) = ERROR_SUCCESS
  Value.RegData = DataType
End Function

Private Function GetKeyInfo(ByRef Value As RegKeyInfo) As Boolean
  ZeroMemory Value, LenB(Value)
  GetKeyInfo = RegQueryInfoKey(FCurrentKey, 0, 0, 0, Value.NumSubKeys, Value.MaxSubKeyLen, 0, _
                               Value.NumValues, Value.MaxValueLen, Value.MaxDataLen, 0, Value.FILETIME) = ERROR_SUCCESS
  
'  If SysLocale.FarEast And (Win32Platform = VER_PLATFORM_WIN32_NT) Then
'    with Value do
'    begin
'      Inc(MaxSubKeyLen, MaxSubKeyLen);
'      Inc(MaxValueLen, MaxValueLen);
'    end;
End Function


Public Sub CloseKey()
  If FCurrentKey <> 0 Then
    If LazyWrite Then
      RegCloseKey FCurrentKey
    Else
      RegFlushKey FCurrentKey
    End If
    FCurrentKey = 0
    FCurrentPath = ""
  End If
End Sub

Public Function CreateKey(ByVal Key As String) As Boolean
Dim TempKey As Long
Dim S As String
Dim Disposition As Long
Dim Relative As Boolean
  
  TempKey = 0
  S = Key
  Relative = IsRelative(S)
  If Not Relative Then S = Mid$(S, 2)
  CreateKey = RegCreateKeyEx(GetBaseKey(Relative), S, 0, 0, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, 0, TempKey, Disposition) = ERROR_SUCCESS
  If CreateKey Then
    RegCloseKey TempKey
  Else
    RaiseError ETErrRegCreateKFailed, , Key
  End If
End Function

Public Function DeleteKey(ByVal Key As String) As Boolean
Dim KLen As Long
Dim I As Long
Dim Relative As Boolean
Dim S As String
Dim Buffer() As Byte
Dim KeyName As String
Dim OldKey As Long
Dim DelKey As Long
Dim Info As RegKeyInfo
Dim FT As FILETIME

  S = Key
  Relative = IsRelative(S)
  If Not Relative Then S = Mid$(S, 2)
  OldKey = FCurrentKey
  DelKey = GetKey(Key)
  If DelKey <> 0 Then
On Error GoTo Finally
    SetCurrentKey DelKey
    If GetKeyInfo(Info) Then
      If Info.NumSubKeys > 8 Then
        If MsgBox("The Key  " & Key & "  has " & Info.NumSubKeys & " sub keys." & vbCrLf & _
                  "Are You Sure to Delete It?", vbQuestion + vbYesNo) = vbNo Then
          SetCurrentKey OldKey
          RegCloseKey DelKey
          Exit Function
        End If
      End If
      
      ReDim Buffer(Info.MaxSubKeyLen)
      For I = Info.NumSubKeys - 1 To 0 Step -1
        KLen = Info.MaxSubKeyLen + 1
        If RegEnumKeyEx(DelKey, I, Buffer(0), KLen, 0, ByVal 0, 0, FT) = ERROR_SUCCESS Then
          KeyName = Left$(StrConv(Buffer(), vbUnicode), KLen)
          DeleteKey KeyName
        End If
      Next I
    End If
Finally:
    SetCurrentKey OldKey
    RegCloseKey DelKey
  End If
  DeleteKey = RegDeleteKey(GetBaseKey(Relative), S) = ERROR_SUCCESS
End Function

Public Function DeleteValue(ByVal Name As String) As Boolean
  DeleteValue = RegDeleteValue(FCurrentKey, Name) = ERROR_SUCCESS
End Function

Public Function GetDataSize(ByVal ValueName As String) As Long
Dim Info As RegDataInfo
  
  If GetDataInfo(ValueName, Info) Then
    GetDataSize = Info.DataSize
  Else
    GetDataSize = -1
  End If
End Function

Public Function GetDataType(ByVal ValueName As String) As ETRegDataType
Dim Info As RegDataInfo
  
  If GetDataInfo(ValueName, Info) Then
    GetDataType = Info.RegData
  Else
    GetDataType = rdUnknown
  End If
End Function

Public Sub GetKeyNames(ByRef Strings As ETStringList)
Dim KLen As Long
Dim I As Long
Dim Info As RegKeyInfo
Dim S As String
Dim Buffer() As Byte
Dim FT As FILETIME
  
  Strings.Clear
  If GetKeyInfo(Info) Then
    ReDim Buffer(Info.MaxSubKeyLen)
    For I = 0 To Info.NumSubKeys - 1
      KLen = Info.MaxSubKeyLen + 1
      If RegEnumKeyEx(FCurrentKey, I, Buffer(0), KLen, 0, ByVal 0, 0, FT) = ERROR_SUCCESS Then
        S = Left$(StrConv(Buffer(), vbUnicode), KLen)
        Strings.Add S
      End If
    Next I
  End If
End Sub

Public Sub GetValueNames(ByRef Strings As ETStringList)
Dim KLen As Long
Dim I As Long
Dim Info As RegKeyInfo
Dim S As String
Dim Buffer() As Byte
  
  Strings.Clear
  If GetKeyInfo(Info) Then
    ReDim Buffer(Info.MaxValueLen)
    For I = 0 To Info.NumValues - 1
      KLen = Info.MaxValueLen + 1
      If RegEnumValue(FCurrentKey, I, Buffer(0), KLen, 0, 0, ByVal 0, 0) = ERROR_SUCCESS Then
        S = Left$(StrConv(Buffer(), vbUnicode), KLen)
        Strings.Add S
      End If
    Next I
  End If
End Sub

Public Function HasSubKeys() As Boolean
Dim Info As RegKeyInfo
  
  HasSubKeys = GetKeyInfo(Info) And (Info.NumSubKeys > 0)
End Function

Public Function KeyExists(ByVal Key As String) As Boolean
Dim TempKey As Long
Dim OldAccess As Long
  
  OldAccess = FAccess
On Error GoTo Finally
    FAccess = STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS
    TempKey = GetKey(Key)
    If TempKey <> 0 Then RegCloseKey TempKey
    KeyExists = TempKey <> 0
Finally:
    FAccess = OldAccess
End Function

Public Function ValueExists(ByVal Name As String) As Boolean
Dim Info As RegDataInfo
  
  ValueExists = GetDataInfo(Name, Info)
End Function

Public Function OpenKey(ByVal Key As String, ByVal CanCreate As Boolean) As Boolean
Dim TempKey As Long
Dim S As String
Dim Disposition As Long
Dim Relative As Boolean
  
  S = Key
  Relative = IsRelative(S)

  If Not Relative Then S = Mid$(S, 2)
  TempKey = 0
  If Not CanCreate Or (S = "") Then
    OpenKey = RegOpenKeyEx(GetBaseKey(Relative), S, 0, FAccess, TempKey) = ERROR_SUCCESS
  Else
    OpenKey = RegCreateKeyEx(GetBaseKey(Relative), S, 0, 0, REG_OPTION_NON_VOLATILE, FAccess, 0, TempKey, Disposition) = ERROR_SUCCESS
  End If
  If OpenKey Then
    If (FCurrentKey <> 0) And Relative Then S = FCurrentPath & "\" & S
    ChangeKey TempKey, S
  End If

End Function

Public Function OpenKeyReadOnly(ByVal Key As String) As Boolean
Dim TempKey As Long
Dim S As String
Dim Relative As Boolean
  
  S = Key
  Relative = IsRelative(S)

  If Not Relative Then S = Mid$(S, 2)
  TempKey = 0
  OpenKeyReadOnly = RegOpenKeyEx(GetBaseKey(Relative), S, 0, KEY_READ, TempKey) = ERROR_SUCCESS
  If OpenKeyReadOnly Then
    FAccess = KEY_READ
    If (FCurrentKey <> 0) And Relative Then S = FCurrentPath & "\" & S
    ChangeKey TempKey, S
  Else
    OpenKeyReadOnly = RegOpenKeyEx(GetBaseKey(Relative), S, 0, STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS, TempKey) = ERROR_SUCCESS
    If OpenKeyReadOnly Then
      FAccess = STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS
      If (FCurrentKey <> 0) And Relative Then S = FCurrentPath & "\" & S
      ChangeKey TempKey, S
    Else
      OpenKeyReadOnly = RegOpenKeyEx(GetBaseKey(Relative), S, 0, KEY_QUERY_VALUE, TempKey) = ERROR_SUCCESS
      If OpenKeyReadOnly Then
        FAccess = KEY_QUERY_VALUE
        If (FCurrentKey <> 0) And Relative Then S = FCurrentPath & "\" & S
        ChangeKey TempKey, S
      End If
    End If
  End If
End Function

Public Function RegistryConnect(ByVal UNCName As String) As Boolean
Dim TempKey As Long
  
  RegistryConnect = RegConnectRegistry(UNCName, FRootKey, TempKey) = ERROR_SUCCESS
  If RegistryConnect Then
    RootKey = TempKey
    FCloseRootKey = True
  End If
End Function

Public Sub RenameValue(ByVal OldName, NewName As String)
Dim KLen As Long
Dim RegData As ETRegDataType
Dim Buffer() As Byte
  
  If ValueExists(OldName) And Not ValueExists(NewName) Then
    KLen = GetDataSize(OldName)
    If KLen > 0 Then
      ReDim Buffer(KLen + 1)
On Error GoTo Finally
      KLen = GetData(OldName, Buffer(0), KLen, RegData)
      DeleteValue OldName
      PutData NewName, Buffer(0), KLen, RegData
    End If
  End If

Finally:
End Sub

Public Function RestoreKey(ByVal Key As String, ByVal FileName As String) As Boolean
Dim RestKey As Long
  
  RestoreKey = False
  RestKey = GetKey(Key)
  If RestKey <> 0 Then
On Error Resume Next
    RestoreKey = RegRestoreKey(RestKey, FileName, 0) = ERROR_SUCCESS
    RegCloseKey RestKey
  End If
End Function

Public Function LoadKey(ByVal Key, FileName As String) As Boolean
Dim S As String
  
  S = Key
  If Not IsRelative(S) Then S = Mid$(S, 2)
  LoadKey = RegLoadKey(RootKey, S, FileName) = ERROR_SUCCESS
End Function

Public Function SaveKey(ByVal Key As String, ByVal FileName As String) As Boolean
Dim SavKey As Long

  SaveKey = False
  SavKey = GetKey(Key)
  If SavKey <> 0 Then
On Error Resume Next
    SaveKey = (RegSaveKey(SavKey, FileName, 0) = 0)
    RegCloseKey SavKey
  End If
End Function

Public Function UnLoadKey(ByVal Key As String) As Boolean
Dim S As String
  
  S = Key
  If Not IsRelative(S) Then S = Mid$(S, 2)
  UnLoadKey = RegUnLoadKey(RootKey, S) = ERROR_SUCCESS
End Function

Public Function ReadBinaryData(ByVal VName As String, Buffer As Byte, ByVal BufSize As Long) As Long
Dim RegData As ETRegDataType
Dim Info As RegDataInfo
  
  If GetDataInfo(VName, Info) Then
    ReadBinaryData = Info.DataSize
    RegData = Info.RegData
    If ((RegData = rdBinary) Or (RegData = rdUnknown)) And (ReadBinaryData <= BufSize) Then
      GetData VName, Buffer, ReadBinaryData, RegData
    Else
      RaiseError ETErrRegCantReadData, "ReadBinaryData", VName
    End If
  Else
    ReadBinaryData = 0
  End If
End Function
    
Public Sub WriteBinaryData(ByVal VName As String, Buffer As Byte, BufSize As Long)
  PutData VName, Buffer, BufSize, rdBinary
End Sub
    
Public Function ReadValue(ByVal VName As String, Optional VType As VariantTypeConstants = vbVNull) As Variant
Dim KLen As Long
Dim RegData As ETRegDataType
Dim Buffer() As Byte

On Error GoTo Skip
  ReadValue = Empty
  KLen = GetDataSize(VName)
  If KLen > 0 Then
    ReDim Buffer(KLen)
    GetData VName, Buffer(0), KLen, RegData
    Select Case RegData
      Case rdString, rdExpandString, rdMultiString
        AuxStr = Left$(StrConv(Buffer(), vbUnicode), KLen - 1): ReadValue = AuxStr
      Case rdInteger: MoveMemory AuxLng, Buffer(0), 4: ReadValue = AuxLng
      Case rdBinary
        If IsMissing(VType) Then
          ReadValue = Buffer
        Else
          Select Case VType
            Case vbString:   AuxStr = Buffer:                  ReadValue = AuxStr '(Unicode)
            Case vbLong:     MoveMemory AuxLng, Buffer(0), 4:  ReadValue = AuxLng
            Case vbInteger:  MoveMemory AuxInt, Buffer(0), 2:  ReadValue = AuxInt
            Case vbSingle:   MoveMemory AuxSng, Buffer(0), 4:  ReadValue = AuxSng
            Case vbDouble:   MoveMemory AuxDbl, Buffer(0), 8:  ReadValue = AuxDbl
            Case vbCurrency: MoveMemory AuxCur, Buffer(0), 8:  ReadValue = AuxCur
            Case vbDate:     MoveMemory AuxDat, Buffer(0), 8:  ReadValue = AuxDat
            Case vbBoolean:  MoveMemory AuxBoo, Buffer(0), 1:  ReadValue = AuxBoo
            Case vbDecimal:  MoveMemory AuxDec, Buffer(0), 14: ReadValue = AuxDec
            Case vbByte:     MoveMemory AuxByt, Buffer(0), 1:  ReadValue = AuxByt
            Case Else:       ReadValue = Buffer
          End Select
        End If
    End Select
  End If
  If VType <> vbVNull Then
    If VarType(ReadValue) <> VType Then
      RaiseError ETErrRegInvalidData, "ReadValue", VName
    End If
  End If
  Exit Function

Skip:
   RaiseError ETErrRegInvalidData, "ReadValue", VName
End Function
    
Public Sub WriteValue(ByVal VName As String, Value As Variant, Optional Unicode As Boolean = False, Optional DType As ETRegDataType = rdUnknown)
Dim VType As VariantTypeConstants
Dim Buffer() As Byte
Dim DT As ETRegDataType
Dim BS As Long

On Error GoTo Skip
  ReDim Buffer(16)
  VType = VarType(Value)
  Select Case VType
    Case vbString:
      AuxStr = Value
      BS = Len(AuxStr)
      If Unicode Then
        BS = BS * 2: Buffer = AuxStr: DT = rdBinary
      Else
        ReDim Buffer(BS): MoveMemory Buffer(0), ByVal AuxStr, BS: DT = rdString
      End If
    Case vbLong:     AuxLng = Value: MoveMemory Buffer(0), AuxLng, 4: BS = 4: DT = rdInteger
    Case vbInteger:  AuxInt = Value: MoveMemory Buffer(0), AuxInt, 2: BS = 2: DT = rdBinary
    Case vbSingle:   AuxSng = Value: MoveMemory Buffer(0), AuxSng, 4: BS = 4: DT = rdBinary
    Case vbDouble:   AuxDbl = Value: MoveMemory Buffer(0), AuxDbl, 8: BS = 8: DT = rdBinary
    Case vbCurrency: AuxCur = Value: MoveMemory Buffer(0), AuxCur, 8: BS = 8: DT = rdBinary
    Case vbDate:     AuxDat = Value: MoveMemory Buffer(0), AuxDat, 8: BS = 8: DT = rdBinary
    Case vbBoolean:  AuxBoo = Value: MoveMemory Buffer(0), AuxBoo, 1: BS = 1: DT = rdBinary
    Case vbDecimal:  AuxDec = Value: MoveMemory Buffer(0), AuxDec, 14: BS = 14: DT = rdBinary
    Case vbByte:     AuxByt = Value: MoveMemory Buffer(0), AuxByt, 1: BS = 1: DT = rdBinary
    Case Else:       RaiseError ETErrRegInvalidData, "WriteValue", VName
  End Select
  If DType <> rdUnknown Then DT = DType
  PutData VName, Buffer(0), BS, DT
  Exit Sub
  
Skip:
   RaiseError ETErrRegInvalidData, "WriteValue", VName
End Sub
    

Public Property Get CurrentKey() As Long
  CurrentKey = FCurrentKey
End Property

Public Property Get CurrentPath() As String
  CurrentPath = FCurrentPath
End Property

Public Property Let LazyWrite(vData As Boolean)
  FLazyWrite = LazyWrite
End Property

Public Property Get LazyWrite() As Boolean
  LazyWrite = FLazyWrite
End Property

Public Property Let RootKey(vData As ETRegistryKey)
  If FRootKey <> vData Then
    If FCloseRootKey Then
      RegCloseKey FRootKey
      FCloseRootKey = False
    End If
    FRootKey = vData
    CloseKey
  End If
End Property

Public Property Get RootKey() As ETRegistryKey
  RootKey = FRootKey
End Property

Public Property Let Access(vData As Long)
  FAccess = Access
End Property

Public Property Get Access() As Long
  Access = FAccess
End Property
Tutte le Utility