VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsRegistry"
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" ,"No"
Option Explicit

' Constants
Private Const REG_SZ = 1
Private Const REG_EXPAND_SZ = 2
Private Const REG_BINARY = 3
Private Const REG_DWORD = 4
Private Const REG_MULTI_SZ = 7

Private Const KEY_QUERY_VALUE = &H1
Private Const KEY_READ = &H20019
Private Const KEY_ALL_ACCESS = &H3F

Private Const REG_OPTION_NON_VOLATILE = 0

' Public Enumerations
Public Enum RegistryRootEnum
    rrClassesRoot = &H80000000
    rrCurrentConfig = &H80000005
    rrCurrentUser = &H80000001
    rrDynData = &H80000006
    rrLocalMachine = &H80000002
    rrUsers = &H80000003
End Enum

Public Enum RegistryDataEnum
    rdNone = 0
    rdString = 1
    rdStringEnviron = 2
    rdBoolean = 3
    rdNumber = 4
    rdStringArray = 7
End Enum

' Private enumerations
Public Enum RegistryErrorEnum
    reSuccess = 0
    reBadDB = 1
    reBadKey = 2
    reCantOpen = 3
    reCantRead = 4
    reCantWrite = 5
    reOutOfMemory = 6
    reArenaTrashed = 7
    reAccessDenied = 8
    reInvalidParameters = 87
    reMoreData = 234
    reNoMoreItems = 259
End Enum

' Type declarations for API calls
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

' API
Private Declare Function ExpandEnvironmentStrings Lib "kernel32" Alias "ExpandEnvironmentStringsA" (ByVal lpSrc As String, ByVal lpDst As String, ByVal nSize As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey 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 String, ByVal dwOptions As Long, ByVal samDesired As Long, lpSecurityAttributes As SECURITY_ATTRIBUTES, 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 RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) 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, ByVal 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, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData 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 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
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpszValueName As String, ByVal lpdwReserved As Long, lpdwType As Long, lpData As Any, lpcbData As Long) 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 SHDeleteKey Lib "shlwapi.dll" Alias "SHDeleteKeyA" (ByVal hKey As Long, ByVal pszSubKey As String) As Long

' Property variables
Private menErrorNumber As RegistryErrorEnum



' METHODS


Public Sub CreateKey(ByVal Key As String, Optional ByVal Root As RegistryRootEnum = rrCurrentUser)
    Dim lngHandle As Long
    Dim typSecurity As SECURITY_ATTRIBUTES

    menErrorNumber = RegCreateKeyEx(Root, Key, 0&, "", 0&, KEY_ALL_ACCESS, typSecurity, lngHandle, 0&)
    If menErrorNumber = reSuccess Then
        RegCloseKey lngHandle
    End If
End Sub

Public Sub DeleteKey(ByVal Key As String, Optional ByVal Root As RegistryRootEnum = rrCurrentUser)
    Dim strKey As String
    Dim lngPos As Long
    Dim lngHandle As Long

    lngPos = InStrRev(Key, "\")
    If lngPos = 0 Then
        strKey = Key
        Key = ""
    Else
        strKey = Mid$(Key, lngPos + 1)
        Key = Left$(Key, lngPos - 1)
    End If
    menErrorNumber = RegOpenKeyEx(Root, Key, 0&, KEY_ALL_ACCESS, lngHandle)
    If menErrorNumber = reSuccess Then
        menErrorNumber = SHDeleteKey(lngHandle, strKey)
        RegCloseKey lngHandle
    End If
End Sub

Public Sub DeleteValue(ByVal Key As String, ByVal Value As String, Optional ByVal Root As RegistryRootEnum = rrCurrentUser)
    Dim lngHandle As Long

    If LCase$(Value) = "(default)" Then Value = ""
    menErrorNumber = RegOpenKeyEx(Root, Key, 0&, KEY_ALL_ACCESS, lngHandle)
    If menErrorNumber = reSuccess Then
        RegDeleteValue lngHandle, Value
        RegCloseKey lngHandle
    End If
End Sub

Public Function EnumerateKeys(ByVal ParentKey As String, ChildKeys() As String, Optional ByVal Root As RegistryRootEnum = rrCurrentUser) As Long
    Dim lngHandle As Long
    Dim lngKeys As Long
    Dim lngMaxLen As Long
    Dim strKey As String
    Dim lngLen As Long
    Dim i As Long
    Dim typFileTime As FILETIME

    menErrorNumber = RegOpenKeyEx(Root, ParentKey, 0&, KEY_READ, lngHandle)
    If menErrorNumber = reSuccess Then
        menErrorNumber = RegQueryInfoKey(lngHandle, vbNullString, 0&, 0&, lngKeys, lngMaxLen, 0&, 0&, 0&, 0&, 0&, typFileTime)
        If menErrorNumber = reSuccess Then
            ReDim ChildKeys(1 To lngKeys)
            For i = 0 To lngKeys - 1
                strKey = Space$(lngMaxLen) & Chr(0)
                lngLen = Len(strKey)
                menErrorNumber = RegEnumKeyEx(lngHandle, i, strKey, lngLen, 0, vbNullString, 0, typFileTime)
                If menErrorNumber <> reSuccess Then Exit For
                ChildKeys(i + 1) = Left$(strKey, lngLen)
            Next
        End If
        RegCloseKey lngHandle
    End If
    EnumerateKeys = lngKeys
End Function

Public Function EnumerateValues(ByVal Key As String, Values() As String, Optional ByVal Root As RegistryRootEnum = rrCurrentUser) As Long
    Dim lngHandle As Long
    Dim lngValues As Long
    Dim lngMaxLen As Long
    Dim strValue As String
    Dim lngLen As Long
    Dim i As Long
    Dim typFileTime As FILETIME
    
    menErrorNumber = RegOpenKeyEx(Root, Key, 0&, KEY_QUERY_VALUE, lngHandle)
    If menErrorNumber = reSuccess Then
        menErrorNumber = RegQueryInfoKey(lngHandle, vbNullString, 0&, 0&, 0&, 0&, 0&, lngValues, lngMaxLen, 0&, 0&, typFileTime)
        If menErrorNumber = reSuccess And lngValues <> 0 Then
            ReDim Values(1 To lngValues)
            For i = 0 To lngValues - 1
                strValue = Space$(lngMaxLen) & Chr(0)
                lngLen = Len(strValue)
                menErrorNumber = RegEnumValue(lngHandle, i, strValue, lngLen, 0&, 0&, ByVal 0&, 0&)
                If menErrorNumber <> reSuccess Then Exit For
                Values(i + 1) = Left$(strValue, lngLen)
            Next
        End If
        RegCloseKey lngHandle
    End If
    EnumerateValues = lngValues
End Function

Public Function GetType(ByVal Key As String, ByVal Value As String, Optional ByVal Root As RegistryRootEnum = rrCurrentUser) As RegistryDataEnum
    Dim lngHandle As Long
    Dim lngType As Long
    
    If LCase$(Value) = "(default)" Then Value = ""
    menErrorNumber = RegOpenKeyEx(Root, Key, 0&, KEY_QUERY_VALUE, lngHandle)
    If menErrorNumber = reSuccess Then
        menErrorNumber = RegQueryValueEx(lngHandle, Value, 0&, lngType, ByVal 0&, 0&)
        If menErrorNumber = reSuccess Then GetType = lngType
        RegCloseKey lngHandle
    End If
End Function

Public Function HasSubKeys(ByVal Key As String, Optional ByVal Root As RegistryRootEnum = rrCurrentUser) As Boolean
    Dim lngHandle As Long
    Dim lngKeys As Long
    Dim typFileTime As FILETIME

    menErrorNumber = RegOpenKeyEx(Root, Key, 0, KEY_QUERY_VALUE, lngHandle)
    If menErrorNumber = reSuccess Then
        menErrorNumber = RegQueryInfoKey(lngHandle, vbNullString, 0&, 0&, lngKeys, 0&, 0&, 0&, 0&, 0&, 0&, typFileTime)
        RegCloseKey lngHandle
    End If
    HasSubKeys = (lngKeys > 0)
End Function

Public Function KeyExists(ByVal Key As String, Optional ByVal Root As RegistryRootEnum = rrCurrentUser) As Boolean
    Dim lngHandle As Long
    
    menErrorNumber = RegOpenKeyEx(Root, Key, 0&, KEY_QUERY_VALUE, lngHandle)
    If menErrorNumber = reSuccess Then
        RegCloseKey lngHandle
        KeyExists = True
    End If
End Function

Public Function ReadBinary(ByVal Key As String, ByVal Value As String, Data() As Byte, Optional ByVal Root As RegistryRootEnum = rrCurrentUser) As Long
    Dim lngHandle As Long
    Dim lngType As Long
    Dim strBuffer As String
    Dim lngLen As Long
    Dim blnData As Boolean
    
    ReadBinary = Default
    If LCase$(Value) = "(default)" Then Value = ""
    menErrorNumber = RegOpenKeyEx(Root, Key, 0&, KEY_QUERY_VALUE, lngHandle)
    If menErrorNumber = reSuccess Then
        menErrorNumber = RegQueryValueEx(lngHandle, Value, 0&, lngType, ByVal 0&, lngLen)
        If menErrorNumber = reSuccess And lngType = rdBoolean Then
            menErrorNumber = RegQueryValueEx(lngHandle, Value, 0&, REG_BINARY, ByVal StrPtr(strBuffer), lngLen)
            If menErrorNumber = reSuccess And lngLen > 0 Then
                ReDim Data(lngLen - 1)
                Data = Left$(strBuffer, lngLen)
                ReadBinary = lngLen
            End If
        End If
        RegCloseKey lngHandle
    End If
End Function

Public Function ReadBoolean(ByVal Key As String, ByVal Value As String, ByVal Default As Boolean, Optional ByVal Root As RegistryRootEnum = rrCurrentUser) As Boolean
    Dim lngHandle As Long
    Dim lngType As Long
    Dim blnData As Boolean
    
    ReadBoolean = Default
    If LCase$(Value) = "(default)" Then Value = ""
    menErrorNumber = RegOpenKeyEx(Root, Key, 0&, KEY_QUERY_VALUE, lngHandle)
    If menErrorNumber = reSuccess Then
        menErrorNumber = RegQueryValueEx(lngHandle, Value, 0&, lngType, ByVal 0&, 0&)
        If menErrorNumber = reSuccess And lngType = rdBoolean Then
            menErrorNumber = RegQueryValueEx(lngHandle, Value, 0&, REG_BINARY, blnData, 2)
            If menErrorNumber = reSuccess Then ReadBoolean = blnData
        End If
        RegCloseKey lngHandle
    End If
End Function

Public Function ReadNumber(ByVal Key As String, ByVal Value As String, ByVal Default As Long, Optional ByVal Root As RegistryRootEnum = rrCurrentUser) As Long
    Dim lngHandle As Long
    Dim lngType As Long
    Dim lngData As Long
    
    ReadNumber = Default
    If LCase$(Value) = "(default)" Then Value = ""
    menErrorNumber = RegOpenKeyEx(Root, Key, 0&, KEY_QUERY_VALUE, lngHandle)
    If menErrorNumber = reSuccess Then
        menErrorNumber = RegQueryValueEx(lngHandle, Value, 0&, lngType, ByVal 0&, 0&)
        If menErrorNumber = reSuccess And lngType = REG_DWORD Then
            menErrorNumber = RegQueryValueEx(lngHandle, Value, 0&, 0&, lngData, 4)
            If menErrorNumber = reSuccess Then ReadNumber = lngData
        End If
        RegCloseKey lngHandle
    End If
End Function

' Thanks to schoolbusdriver from vbforums.com
Public Function ReadString(ByVal Key As String, ByVal Value As String, ByVal Default As String, Optional ByVal Root As RegistryRootEnum = rrCurrentUser) As String
    Dim lngHandle As Long
    Dim lngType As Long
    Dim strData As String
    Dim lngLen As Long
    
    ReadString = Default
    If LCase$(Value) = "(default)" Then Value = ""
    menErrorNumber = RegOpenKeyEx(Root, Key, 0&, KEY_QUERY_VALUE, lngHandle)
    If menErrorNumber = reSuccess Then
        menErrorNumber = RegQueryValueEx(lngHandle, Value, 0&, lngType, 0&, lngLen)
        If menErrorNumber = reMoreData Then
            menErrorNumber = reSuccess
            If lngType = REG_SZ Then
                strData = Space$(lngLen)
                menErrorNumber = RegQueryValueEx(lngHandle, Value, 0&, 0&, ByVal strData, lngLen)
                If menErrorNumber = reSuccess Then ReadString = Left$(strData, lngLen - 1)
            End If
        End If
        RegCloseKey lngHandle
    End If
End Function

Public Function ReadStringArray(ByVal Key As String, Value As String, Data() As String, Optional ByVal Root As RegistryRootEnum = rrCurrentUser) As Long
    Dim lngHandle As Long
    Dim lngType As Long
    Dim strData As String
    Dim lngLen As Long
    
    ReadStringArray = Default
    If LCase$(Value) = "(default)" Then Value = ""
    menErrorNumber = RegOpenKeyEx(Root, Key, 0&, KEY_QUERY_VALUE, lngHandle)
    If menErrorNumber = reSuccess Then
        menErrorNumber = RegQueryValueEx(lngHandle, Value, 0&, lngType, 0&, lngLen)
        If menErrorNumber = reMoreData Then
            menErrorNumber = reSuccess
            If lngType = REG_MULTI_SZ Then
                strData = Space$(lngLen)
                menErrorNumber = RegQueryValueEx(lngHandle, Value, 0&, 0&, ByVal strData, lngLen)
                If menErrorNumber = reSuccess Then
                    strData = Left$(strData, lngLen - 2)
                    Data = Split(strData, Chr$(0))
                    ReadStringArray = UBound(Data)
                End If
            End If
        End If
        RegCloseKey lngHandle
    End If
End Function

Public Function ReadStringEnviron(ByVal Key As String, ByVal Value As String, ByVal Default As String, Optional ByVal Expanded As Boolean = True, Optional ByVal Root As RegistryRootEnum = rrCurrentUser) As String
    Dim lngHandle As Long
    Dim lngType As Long
    Dim strData As String
    Dim strExpanded As String
    Dim lngLen As Long
    
    ReadStringEnviron = Default
    If LCase$(Value) = "(default)" Then Value = ""
    menErrorNumber = RegOpenKeyEx(Root, Key, 0&, KEY_QUERY_VALUE, lngHandle)
    If menErrorNumber = reSuccess Then
        menErrorNumber = RegQueryValueEx(lngHandle, Value, 0&, lngType, 0&, lngLen)
        If menErrorNumber = reMoreData Then
            menErrorNumber = reSuccess
            If lngType = REG_EXPAND_SZ Then
                strData = Space$(lngLen)
                menErrorNumber = RegQueryValueEx(lngHandle, Value, 0&, 0&, ByVal strData, lngLen)
                If menErrorNumber = reSuccess Then
                    strData = Left$(strData, lngLen - 1)
                    If Expanded Then
                        lngLen = lngLen + 1023
                        strExpanded = Space$(lngLen)
                        lngLen = ExpandEnvironmentStrings(strData, strExpanded, lngLen)
                        strData = Left$(strExpanded, lngLen - 1)
                    End If
                    ReadStringEnviron = strData
                End If
            End If
        End If
        RegCloseKey lngHandle
    End If
End Function

Public Function ValueExists(ByVal Key As String, ByVal Value As String, Optional ByVal Root As RegistryRootEnum = rrCurrentUser) As Boolean
    Dim lngHandle As Long
    
    If LCase$(Value) = "(default)" Then Value = ""
    menErrorNumber = RegOpenKeyEx(Root, Key, 0&, KEY_QUERY_VALUE, lngHandle)
    If menErrorNumber = reSuccess Then
        ValueExists = (RegQueryValueEx(lngHandle, Value, 0&, 0&, ByVal 0&, 0&) = reSuccess)
        RegCloseKey lngHandle
    End If
End Function

Public Sub WriteBoolean(ByVal Key As String, ByVal Value As String, ByVal Data As Boolean, Optional ByVal Root As RegistryRootEnum = rrCurrentUser)
    Dim lngHandle As Long
    Dim typSecurity As SECURITY_ATTRIBUTES

    If LCase$(Value) = "(default)" Then Value = ""
    menErrorNumber = RegCreateKeyEx(Root, Key, 0&, vbNullString, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, typSecurity, lngHandle, 0&)
    If menErrorNumber = reSuccess Then
        RegSetValueEx lngHandle, Value, 0&, REG_BINARY, Data, 2
        RegCloseKey lngHandle
    End If
End Sub

Public Sub WriteNumber(ByVal Key As String, ByVal Value As String, ByVal Data As Long, Optional ByVal Root As RegistryRootEnum = rrCurrentUser)
    Dim lngHandle As Long
    Dim typSecurity As SECURITY_ATTRIBUTES
    
    If LCase$(Value) = "(default)" Then Value = ""
    menErrorNumber = RegCreateKeyEx(Root, Key, 0&, vbNullString, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, typSecurity, lngHandle, 0&)
    If menErrorNumber = reSuccess Then
        RegSetValueEx lngHandle, Value, 0&, REG_DWORD, Data, 4
        RegCloseKey lngHandle
    End If
End Sub

Public Sub WriteString(ByVal Key As String, ByVal Value As String, ByVal Data As String, Optional ByVal Root As RegistryRootEnum = rrCurrentUser)
    Dim lngHandle As Long
    Dim lngLen As Long
    Dim typSecurity As SECURITY_ATTRIBUTES
    
    If LCase$(Value) = "(default)" Then Value = ""
    menErrorNumber = RegCreateKeyEx(Root, Key, 0&, vbNullString, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, typSecurity, lngHandle, 0&)
    If menErrorNumber = reSuccess Then
        lngLen = Len(Data)
        RegSetValueEx lngHandle, Value, 0&, REG_SZ, ByVal Data, lngLen
        RegCloseKey lngHandle
    End If
End Sub

Public Sub WriteStringArray(ByVal Key As String, ByVal Value As String, Data() As String, Optional ByVal Root As RegistryRootEnum = rrCurrentUser)
    Dim strData As String
    Dim lngHandle As Long
    Dim lngLen As Long
    Dim typSecurity As SECURITY_ATTRIBUTES
    
    strData = Join(Data, Chr$(0))
    strData = strData & Chr$(0) & Chr$(0)
    If LCase$(Value) = "(default)" Then Value = ""
    menErrorNumber = RegCreateKeyEx(Root, Key, 0&, vbNullString, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, typSecurity, lngHandle, 0&)
    If menErrorNumber = reSuccess Then
        lngLen = Len(strData)
        RegSetValueEx lngHandle, Value, 0&, REG_MULTI_SZ, ByVal strData, lngLen
        RegCloseKey lngHandle
    End If
End Sub

Public Sub WriteStringEnviron(ByVal Key As String, ByVal Value As String, ByVal Data As String, Optional ByVal Root As RegistryRootEnum = rrCurrentUser)
    Dim lngHandle As Long
    Dim lngLen As Long
    Dim typSecurity As SECURITY_ATTRIBUTES
    
    If LCase$(Value) = "(default)" Then Value = ""
    menErrorNumber = RegCreateKeyEx(Root, Key, 0&, vbNullString, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, typSecurity, lngHandle, 0&)
    If menErrorNumber = reSuccess Then
        lngLen = Len(Data)
        RegSetValueEx lngHandle, Value, 0&, REG_EXPAND_SZ, ByVal Data, lngLen
        RegCloseKey lngHandle
    End If
End Sub



' PROPERTIES


' ErrorNumber
Public Property Get ErrorNumber() As RegistryErrorEnum
    ErrorNumber = menErrorNumber
End Property


' ErrorDescription
Public Property Get ErrorDescription() As String
    Select Case menErrorNumber
        Case reSuccess: ErrorDescription = ""
        Case reBadDB: ErrorDescription = "Bad DB"
        Case reBadKey: ErrorDescription = "Bad key"
        Case reCantOpen: ErrorDescription = "Can't open"
        Case reCantRead: ErrorDescription = "Can't read"
        Case reCantWrite: ErrorDescription = "Can't write"
        Case reOutOfMemory: ErrorDescription = "Out of memory"
        Case reArenaTrashed: ErrorDescription = "Arena trashed"
        Case reAccessDenied: ErrorDescription = "Access denied"
        Case reInvalidParameters: ErrorDescription = "Invalid parameters"
        Case reMoreData: ErrorDescription = "More data"
        Case reNoMoreItems: ErrorDescription = "No more items"
        Case Else: ErrorDescription = "Unknown error"
    End Select
End Property