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
Option Explicit
'
Private priv_strKey As String
Private priv_bAutocreate As Boolean
Private priv_bKeyExists As Boolean
'
Public Enum regTypes
    REG_NONE = 0
    REG_SZ = 1
    REG_EXPAND_SZ = 2
    REG_BINARY = 3
    REG_DWORD = 4
End Enum
'
Public Enum regErrors
    ERR_INVALID_KEY = vbObjectError + 512 + 2
    ERR_UNKNOWN_ROOT = vbObjectError + 512 + 3
    ERR_OPEN_FAIL = vbObjectError + 512 + 4
    ERR_NOCREATION = vbObjectError + 512 + 5
    ERR_NOLETPROPERTY = vbObjectError + 512 + 7
    ERR_READ_FAIL = vbObjectError + 512 + 8
    ERR_BINDATA = vbObjectError + 512 + 12
    ERR_CREATE_FAIL = vbObjectError + 512 + 15
End Enum
'
Private Type SECURITY_ATTRIBUTES
    nLength              As Long
    lpSecurityDescriptor As Long
    bInheritHandle       As Boolean
End Type
'
Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type
'
Private Const MAX_SIZE = 2048
'
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_CURRENT_CONFIG = &H80000005
Private Const HKEY_DYN_DATA = &H80000006
'
Private Const ERROR_SUCCESS = 0&
Private Const ERROR_MORE_DATA = 234
Private Const ERROR_NO_MORE_ITEMS = 259&
'
Private Const REG_OPTION_NON_VOLATILE = 0
Private Const REG_CREATED_NEW_KEY = &H1
Private Const REG_OPENED_EXISTING_KEY = &H2
'
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_ALL_ACCESS = &HF003F
'
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 RegDeleteValue Lib "advapi32.dll" _
        Alias "RegDeleteValueA" _
        (ByVal hKey As Long, ByVal lpValueName As String) _
        As Long

Private Declare Function RegDeleteKey Lib "advapi32.dll" _
        Alias "RegDeleteKeyA" _
        (ByVal hKey As Long, ByVal lpSubKey As String) 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 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 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 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 RegCloseKey Lib "advapi32.dll" _
        (ByVal hKey As Long) As Long

Public Function delKey() As Long
    Dim lngPos As Long
    Dim strParent As String
    Dim strChild As String
    Dim lngHdle As Long
    Dim boolKeyDel As Boolean
    '
    Key = priv_strKey
    If Right(Key, 1) = "\" Then
        'Unterschlüsel löschen
        Key = Left(Key, Len(Key) - 1)
        If Right(Key, 1) = "\" Then Err.Raise ERR_INVALID_KEY, "delKey", "Ungültiger Schlüssel!"
        boolKeyDel = True
    Else
        'Wert löschen
        boolKeyDel = False
    End If
    
    lngPos = InStrRev(Key, "\")
    If lngPos = 0 Then
        Err.Raise ERR_INVALID_KEY, "delKey", "Ungültiger Schlüssel!"
    End If

    strParent = Left(Key, lngPos - 1)
    strChild = Mid(Key, lngPos + 1)
    lngHdle = OpenKey(strParent)
    If boolKeyDel Then
        'Schlüssel löschen
        delKey = RegDeleteKey(lngHdle, strChild)
    Else
        'Wert löschen
        delKey = RegDeleteValue(lngHdle, strChild)
    End If
End Function

Public Function regEnum() As Collection
    Dim collKeyList As New Collection
    Dim lngHdle As Long
    Dim strStore As String
    Dim lngResult As Long
    Dim lngIdx As Long
    Dim lngStoreSize As Long
    Dim LastWriteTime As FILETIME
   
    Key = priv_strKey
    lngIdx = 0
    If Right(Key, 1) = "\" Then
        'Schlüssel aufzählen
        lngHdle = OpenKey(Key)
        Do
            strStore = Space(MAX_SIZE)
            lngStoreSize = MAX_SIZE
            lngResult = RegEnumKeyEx(lngHdle, lngIdx, strStore, lngStoreSize, 0&, 0&, 0&, LastWriteTime)
            If lngResult <> ERROR_NO_MORE_ITEMS Then
                collKeyList.Add Left(strStore, lngStoreSize)
                lngIdx = lngIdx + 1
            End If
        Loop Until lngResult = ERROR_NO_MORE_ITEMS

    Else
        'Werte aufzählen
        lngHdle = OpenKey(Key)
        Do
            strStore = Space(MAX_SIZE)
            lngStoreSize = MAX_SIZE
            lngResult = RegEnumValue(lngHdle, lngIdx, strStore, lngStoreSize, ByVal 0&, ByVal 0&, ByVal 0&, ByVal 0&)
            If lngResult <> ERROR_NO_MORE_ITEMS Then
                collKeyList.Add Left(strStore, lngStoreSize)
                lngIdx = lngIdx + 1
            End If
        Loop While lngResult <> ERROR_NO_MORE_ITEMS

    End If
    Call RegCloseKey(lngHdle)
    Set regEnum = collKeyList
End Function

Public Function getValue() As Variant
    Dim lngLength As Long
    Dim strMain As String
    Dim strSub As String
    Dim lngPos As Long
    Dim lngHdle As Long
    Dim lngResult As Long
    Dim strStore As String
    Dim lngDataVal As Long
    Dim lngType As Long
    Dim lngZ As Long
    Dim intCode As Integer
    
    Key = priv_strKey
    'Schlüssel splitten
    lngPos = InStrRev(Key, "\")
    If lngPos = 0 Then
       Err.Raise ERR_INVALID_KEY, "getValue", "Ungültiger Schlüssel: """ & Key & """"
    End If
    strMain = Left(Key, lngPos - 1)
    strSub = Mid(Key, lngPos + 1)
    lngHdle = OpenKey(strMain)
    lngResult = RegQueryValueEx(lngHdle, strSub, 0, lngType, "", lngLength)
    
    If lngResult = ERROR_MORE_DATA Then
        If lngType = regTypes.REG_SZ Or lngType = regTypes.REG_EXPAND_SZ Then
            strStore = Space(lngLength)
            lngResult = RegQueryValueEx(lngHdle, strSub, 0, lngType, ByVal strStore, lngLength)
            If lngLength = 0 Then
                strStore = ""
            Else
                strStore = Left(strStore, lngLength - 1)
            End If
        ElseIf lngType = regTypes.REG_BINARY Then
            ReDim bytearray(lngLength) As Byte
            lngResult = RegQueryValueEx(lngHdle, strSub, 0, lngType, bytearray(0), lngLength)
            For lngZ = 1 To lngLength
                intCode = bytearray(lngZ - 1)
                getValue = getValue & Right("0" & Hex(intCode), 2) & " "
            Next
            strStore = Trim(getValue)
        ElseIf lngType = regTypes.REG_DWORD Then
            lngResult = RegQueryValueEx(lngHdle, strSub, 0, lngType, lngDataVal, 4)
            strStore = CStr(lngDataVal)
        End If
    End If
    If lngResult = ERROR_SUCCESS Then
            getValue = strStore
    Else
        Err.Raise ERR_READ_FAIL, "getValue", "Kann Schlüssel nicht lesen """ & Key & """"
    End If
    Call RegCloseKey(lngHdle)
End Function

Public Function setValue(ByVal strStore As String, Optional ByVal regType As Long = regTypes.REG_SZ) As Boolean
    Dim strMain As String
    Dim strValname As String
    Dim lngPos As Long
    Dim lngHdle As Long
    Dim lngLength As Long
    Dim lngResult As Long
    Dim lngCount As Long
    Dim strChar As String
    Dim strVals As String
    Dim x As Long
    Dim strSngle As String
    Dim intSngle As Integer
    Dim lngData As Long
    Dim strRoot As String
    Dim strNewkey As String
    Dim lngTempHdle As Long
    Dim secAttribs As SECURITY_ATTRIBUTES
    Dim lngDispo As Long
    Dim strAnsi As String

    Key = priv_strKey
    lngPos = InStrRev(Key, "\")
    If lngPos = 0 Then
       Err.Raise ERR_INVALID_KEY, "getValue", "Ungültiger Schlüssel: """ & Key & """"
    End If
    strMain = Left(Key, lngPos - 1)
    strValname = Mid(Key, lngPos + 1)
        
    If InStr(strMain, "\") = 0 Then
        'Hauptschlüssel
        lngHdle = OpenKey(strMain)
    Else
        'Benannter Schlüssel, eventuell anlegen
        If Me.KeyExists = False And Me.autoCreate = False Then
            Err.Raise ERR_NOCREATION, "setValue", "Schlüssel wird nicht angelegt"
        End If
        '
        lngPos = InStr(strMain, "\")
        strRoot = Left(strMain, lngPos - 1)
        strNewkey = Mid(strMain, lngPos + 1)
        lngTempHdle = OpenKey(strRoot)
        lngResult = RegCreateKeyEx(lngTempHdle, strNewkey, 0, "", REG_OPTION_NON_VOLATILE, KEY_CREATE_SUB_KEY Or KEY_SET_VALUE, secAttribs, lngHdle, lngDispo)
    End If
    
    If lngHdle = 0 Then
        Err.Raise ERR_CREATE_FAIL, "setValue", "Fehler beim Erstellen/Zugriff auf Schlüssel """ & Key & """ Error #: " & lngResult
    End If
    
    Select Case regType
        Case regTypes.REG_SZ
            lngLength = Len(strStore) + 1
            lngResult = RegSetValueEx(lngHdle, strValname, 0, REG_SZ, ByVal strStore, lngLength)
        Case regTypes.REG_BINARY
            strStore = Trim(strStore) & " "
            lngCount = 0
            strVals = ""
            strChar = ""
            For x = 1 To Len(strStore)
                strSngle = Mid(strStore, x, 1)
                If strSngle = " " Then
                    intSngle = Fix("&H" & strChar)
                    If intSngle > 255 Then
                        Err.Raise ERR_BINDATA, "setValue", "Ungültige Binärzahl (größer als 255): """ & strStore & """"
                    End If
                    strVals = strVals & Chr(intSngle)
                    lngCount = lngCount + 1
                    strChar = ""
                Else
                    strChar = strChar & strSngle
                End If
            Next
            
            strAnsi = StrConv(strVals, vbFromUnicode)
            lngResult = RegSetValueEx(lngHdle, strValname, 0, REG_BINARY, ByVal StrPtr(strAnsi), lngCount)
        
        Case regTypes.REG_DWORD
            lngLength = 4
            lngData = CLng(strStore)
            lngResult = RegSetValueEx(lngHdle, strValname, 0, REG_DWORD, lngData, lngLength)
    End Select
    Call RegCloseKey(lngHdle)
    If lngResult = ERROR_SUCCESS Then
        setValue = True
    Else
        setValue = False
    End If
End Function

Private Function getRoot(ByVal Key As String) As Long
    Select Case UCase(Key)
        Case "HKCU", "HKEY_CURRENT_USER"
            getRoot = HKEY_CURRENT_USER
        Case "HKLM", "HKEY_LOCAL_MACHINE"
            getRoot = HKEY_LOCAL_MACHINE
        Case "HKU", "HKEY_USERS"
            getRoot = HKEY_USERS
        Case "HKDD", "HKEY_DYN_DATA"
            getRoot = HKEY_DYN_DATA
        Case "HKCC", "HKEY_CURRENT_CONFIG"
            getRoot = HKEY_CURRENT_CONFIG
        Case "HKCR", "HKEY_CLASSES_ROOT"
            getRoot = HKEY_CLASSES_ROOT
        Case Else
            Err.Raise ERR_UNKNOWN_ROOT, "getRoot", "Unbekannter Hauptschlüssel: """ & Key & """"
    End Select
End Function

Private Function OpenKey(ByVal Key As String) As Long
    Dim lngPos As Long
    Dim strMain As String
    Dim strSub As String
    Dim lngResult As Long
    
    lngPos = InStr(Key, "\")
    If lngPos = 0 Then
        'Hauptschlüssel
        OpenKey = getRoot(Key)
    Else
        strMain = Left(Key, lngPos - 1)
        strSub = Mid(Key, lngPos + 1)
        lngResult = RegOpenKeyEx(getRoot(strMain), strSub, 0, KEY_ALL_ACCESS, OpenKey)
        If lngResult <> ERROR_SUCCESS Then
            Err.Raise ERR_OPEN_FAIL, "OpenKey", "Kann Schlüssel nicht öffnen """ & Key & """, Error # " & lngResult
        End If
    End If
End Function

Public Property Get Key() As String
 Key = priv_strKey
End Property

Public Property Let Key(k As String)
 If k = vbNullString Or k = "\" Then
    Err.Raise ERR_INVALID_KEY, "Let Key", "Ungültiger Schlüssel"
 Else
    priv_strKey = k
 End If
End Property
Public Property Get autoCreate() As Boolean
 autoCreate = priv_bAutocreate
End Property

Public Property Let autoCreate(b As Boolean)
 priv_bAutocreate = b
End Property

Private Sub Class_Initialize()
    priv_bAutocreate = True
End Sub

Public Property Get KeyExists() As Boolean
    Dim lngHdle As Long
    '
    On Error Resume Next
    Key = priv_strKey
    If Right(Key, 1) = "\" Then
        'Schlüssel
        lngHdle = OpenKey(Key)
        priv_bKeyExists = Not (lngHdle = 0)
        Err.Clear
        If Not lngHdle = 0 Then RegCloseKey (lngHdle)
    Else
        'Wert
        On Error Resume Next
        Call getValue
        priv_bKeyExists = (Err.Number = 0)
        Err.Clear
    End If
    KeyExists = priv_bKeyExists
    On Error GoTo 0
End Property
Public Property Let KeyExists(dummy As Boolean)
       Err.Raise ERR_NOLETPROPERTY, "keyExists", ""
End Property