Attribute VB_Name = "MRegistry"
Option Explicit

'Modul für den Zugriff auf die Windows-Registierungsdatenbank (Registry)
'© 2000-2002, INOSOFT GmbH
'Version 4.04.000

'Funktionen:
'-Read          Liest einen Wert aus der Windows-Registierungsdatenbank
'-ReadEx        Liest einen Wert aus der Windows-Registierungsdatenbank (mit Wertprüfung)
'-Store         Schreibt einen Wert in die Windows-Registierungsdatenbank
'-Keys          Gibt alle (Unter)-Schlüssel eines Pfades der Windows-Registierungsdatenbank zurück
'-Values        Gibt alle Einträge eines Pfades der Windows-Registierungsdatenbank zurück
'-DeleteKey     Entfernt einen kompletten Schlüssel (inkl. Werte und Unterschlüssel)
'-DeleteValue   Entfernt einen Wert aus der Windows-Registierungsdatenbank

'Abhängigkeiten/zusätzliche Dateien:
'-CVWValue.cls    Klassenmodul "CVWValue"

Public Enum ERegType
    REG_NONE = 0
    REG_SZ = 1
    REG_EXPAND_SZ = 2
    REG_BINARY = 3
    REG_DWORD = 4
    REG_MULTI_SZ = 7
End Enum

Public Enum ERegLevel
    HKEY_CLASSES_ROOT = &H80000000
    HKEY_CURRENT_CONFIG = &H80000005
    HKEY_CURRENT_USER = &H80000001
    HKEY_DYN_DATA = &H80000006
    HKEY_LOCAL_MACHINE = &H80000002
    HKEY_PERFORMANCE_DATA = &H80000004
    HKEY_USERS = &H80000003
End Enum



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 READ_CONTROL = &H20000
Private Const STANDARD_RIGHTS_READ = (READ_CONTROL)
Private Const KEY_NOTIFY = &H10
Private Const SYNCHRONIZE = &H100000
Private Const KEY_READ = ((STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY) And (Not SYNCHRONIZE))

Private Const ERROR_SUCCESS = 0&
Private Const ERROR_FILE_NOT_FOUND = 2&
Private Const ERROR_NO_MORE_ITEMS = 259&
Private Const ERROR_MORE_DATA = 234

Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type


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 Long, _
    phkResult As Long, _
    lpdwDisposition 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 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 RegSetValueExStr Lib "advapi32.dll" 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 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 RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" _
    (ByVal hKey As Long, _
    ByVal lpSubKey As String _
    ) As Long
Private Declare Function SHDeleteKey Lib "shlwapi.dll" Alias "SHDeleteKeyA" _
    (ByVal hKey As Long, _
    ByVal lpSubKey As String _
    ) 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 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, _
    lpCVWValues 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, _
    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 Read(ByVal Level As ERegLevel, _
                     ByVal Path As String, _
                     ByVal Name As String, _
                     Optional ByVal Default As Variant _
                    ) As Variant
    'Liest einen Wert aus der Windows-Registierungsdatenbank
    'Eingabe:
    '  Level: Bereich der Registrierung
    '  Path: Pfad des Eintrags
    '  Name: Name des Eintrags
    '  Default: Vorgabewert, wenn kein Eintrag gefunden wurde
    'Ausgabe:
    '  Read: Wert des Eintrags als Long/String/Bytefeld
    '        oder Default, wenn nicht vorhanden
    'Anwendung:
    '  Dim s as string
    '  s = MRegistry.Read(HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Windows\CurrentVersion", "CommonFilesDir")
    '
    '  Dim v As Variant
    '  'Liest den Eintrag "ZZZ" aus dem Pfad "HKEY_LOCAL_MACHINE\SOFTWARE\XXX"
    '  'Ist der Eintrag nicht vorhanden, wird je nach Default-Belegung ein anderer Rückgabewert geliefert
    '  v = MRegistry.Read(HKEY_LOCAL_MACHINE, "SOFTWARE\XXX", "ZZZ")      ' Null
    '  v = MRegistry.Read(HKEY_LOCAL_MACHINE, "SOFTWARE\XXX", "ZZZ", 1)   ' 1 (Integer)
    '  v = MRegistry.Read(HKEY_LOCAL_MACHINE, "SOFTWARE\XXX", "ZZZ", "1") ' "1" (String)
    
    Dim hKey As Long, lR As Long, lLen As Long, enmRegTyp As ERegType
    Dim sBuffer As String, lBuffer As Long, bBuffer() As Byte
    
    If IsMissing(Default) Then
        Read = Null
    Else
        Read = Default
    End If
    
    lR = RegOpenKeyEx(Level, Path, 0, KEY_QUERY_VALUE, hKey)
    If lR = ERROR_SUCCESS Then
        lLen = 0
        lR = RegQueryValueEx(hKey, Name, 0, enmRegTyp, ByVal 0&, lLen)
        If lR = ERROR_SUCCESS Then
            Select Case enmRegTyp
                Case REG_SZ, REG_EXPAND_SZ, REG_MULTI_SZ
                    lLen = lLen + 2
                    sBuffer = Space$(lLen)
                    lR = RegQueryValueEx(hKey, Name, 0, enmRegTyp, ByVal sBuffer, lLen)
                    If lR = ERROR_SUCCESS Then
                        If lLen = 0 Then
                            Read = ""
                        Else
                            Read = Left$(sBuffer, lLen - 1)
                        End If
                    End If
                Case REG_BINARY
                    ReDim bBuffer(lLen - 1)
                    lR = RegQueryValueEx(hKey, Name, 0, enmRegTyp, bBuffer(0), lLen)
                    If lR = ERROR_SUCCESS Then
                        Read = bBuffer
                    End If
                Case REG_DWORD
                    lR = RegQueryValueEx(hKey, Name, 0, enmRegTyp, lBuffer, lLen)
                    If lR = ERROR_SUCCESS Then
                        Read = lBuffer
                    End If
            End Select
        End If
        RegCloseKey hKey
    End If
End Function

Public Function ReadEx(ByVal Level As ERegLevel, _
                       ByVal Path As String, _
                       ByVal Name As String, _
                       Optional ByVal Default As Variant, _
                       Optional ByVal Minimum As Variant, _
                       Optional ByVal Maximum As Variant _
                      ) As Variant
    'Liest einen Wert aus der Windows-Registierungsdatenbank
    'Eingabe:
    '  Level: Bereich der Registrierung
    '  Path: Pfad des Eintrags
    '  Name: Name des Eintrags
    '  Default: Vorgabewert, wenn kein Eintrag gefunden wurde
    '  Minimum/Maximum: Grenzen, in denen der Wert liegen muss,
    '                   andernfalls wird der Default-Wert zurückgegeben
    'Ausgabe:
    '  ReadEx: Wert des Eintrags als Long/String/Bytefeld
    '          oder Default, wenn nicht vorhanden
    
    Dim hKey As Long, lR As Long, lLen As Long, enmRegTyp As ERegType
    Dim sBuffer As String, lBuffer As Long, bBuffer() As Byte
    
    If IsMissing(Default) Then
        ReadEx = Null
    Else
        ReadEx = Default
    End If
    
    lR = RegOpenKeyEx(Level, Path, 0, KEY_QUERY_VALUE, hKey)
    If lR = ERROR_SUCCESS Then
        lLen = 0
        lR = RegQueryValueEx(hKey, Name, 0, enmRegTyp, ByVal 0&, lLen)
        If lR = ERROR_SUCCESS Then
            Select Case enmRegTyp
                Case REG_SZ, REG_EXPAND_SZ, REG_MULTI_SZ
                    lLen = lLen + 2
                    sBuffer = Space$(lLen)
                    lR = RegQueryValueEx(hKey, Name, 0, enmRegTyp, ByVal sBuffer, lLen)
                    If lR = ERROR_SUCCESS Then
                        If lLen = 0 Then
                            ReadEx = ""
                        Else
                            ReadEx = Left$(sBuffer, lLen - 1)
                        End If
                    End If
                Case REG_BINARY
                    ReDim bBuffer(lLen - 1)
                    lR = RegQueryValueEx(hKey, Name, 0, enmRegTyp, bBuffer(0), lLen)
                    If lR = ERROR_SUCCESS Then
                        ReadEx = bBuffer
                    End If
                Case REG_DWORD
                    lR = RegQueryValueEx(hKey, Name, 0, enmRegTyp, lBuffer, lLen)
                    If lR = ERROR_SUCCESS Then
                        ReadEx = lBuffer
                    End If
            End Select
        End If
        RegCloseKey hKey
    End If
    
    If Not IsMissing(Minimum) Then
        If ReadEx < Minimum Then
            If IsMissing(Default) Then
                ReadEx = Minimum
            Else
                ReadEx = Default
            End If
        End If
    End If
    If Not IsMissing(Maximum) Then
        If ReadEx > Maximum Then
            If IsMissing(Default) Then
                ReadEx = Maximum
            Else
                ReadEx = Default
            End If
        End If
    End If
End Function

Public Function Store(ByVal Level As ERegLevel, _
                      ByVal Path As String, _
                      ByVal Name As Variant, _
                      ByVal Value As Variant, _
                      ByVal KeyType As ERegType _
                     ) As Boolean
    'Schreibt einen Wert in die Windows-Registierungsdatenbank
    'Eingabe:
    '  Level: Bereich der Registrierung
    '  Path: Pfad des Eintrags
    '  Name: Name des Eintrags
    '        oder Null => Pfad wird komplett entfernt
    '  Value: neuer Wert des Eintrags (Long/String/Bytefeld)
    '         oder Null => Eintrag wird entfernt
    '  KeyType: Datentyp des Eintrags
    'Ausgabe:
    '  Store: True=Wert geschrieben
    '         False=Fehler, Wert nicht geschrieben
    'Anwendung:
    '  MRegistry.Store HKEY_LOCAL_MACHINE, "SOFTWARE\XXX", "ZZZ", 123, REG_DWORD
    '  MRegistry.Store HKEY_LOCAL_MACHINE, "SOFTWARE\XXX", "ZZZ", "Hallo", REG_SZ
    
    Dim hKey As Long, lR As Long
    Dim sBuffer As String, lBuffer As Long, bBuffer() As Byte
    
    Store = False
    
    If IsNull(Name) Then
        'Pfad komplett entfernen
        Store = DeleteKey(Level, Path)
    ElseIf IsNull(Value) Then
        'Eintrag entfernen
        Store = DeleteValue(Level, Path, Name)
    Else
        'Eintrag schreiben
        lR = RegCreateKeyEx(Level, Path, 0, vbNullString, 0, KEY_SET_VALUE + KEY_CREATE_SUB_KEY, ByVal 0&, hKey, lBuffer)
        If lR = ERROR_SUCCESS Then
            'Eintrag schreiben
            Select Case KeyType
                Case REG_SZ, REG_EXPAND_SZ
                    sBuffer = Value
                    lR = RegSetValueExStr(hKey, Name, 0, KeyType, sBuffer, Len(sBuffer))
                Case REG_MULTI_SZ
                    sBuffer = Value
                    lR = RegSetValueExStr(hKey, Name, 0, KeyType, sBuffer, Len(sBuffer))
                Case REG_DWORD
                    lBuffer = Value
                    lR = RegSetValueEx(hKey, Name, 0, KeyType, lBuffer, 4)
                Case REG_BINARY
                    bBuffer = Value
                    lR = RegSetValueEx(hKey, Name, 0, KeyType, bBuffer(0), UBound(bBuffer) + 1)
                Case Else
                    lR = Not ERROR_SUCCESS
            End Select
        End If
        If lR = ERROR_SUCCESS Then
            Store = True
        End If
        RegCloseKey hKey
    End If
End Function

Public Function Values(ByVal Level As ERegLevel, _
                       ByVal Path As String _
                      ) As Collection
    'Gibt alle Einträge eines Pfades der Windows-Registierungsdatenbank zurück
    'Eingabe:
    '  Level: Bereich der Registrierung
    '  Path: Pfad des Eintrags (Name des Schlüssels)
    'Ausgabe:
    '  Values: Collection mit CVWValue-Elementen mit den Einträgen:
    '          CVWValue enthält den Namen und den Wert des Eintrags.
    'Anwendung:
    '  Dim col As Collection, c As CVWValue
    '  Set col = MRegistry.Values(HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Windows\CurrentVersion")
    '  For Each c In col
    '    Debug.Print c.Name; "="; c.Value
    '  Next c
    
    Dim hKey As Long, lR As Long, lIndex As Long, enmRegTyp As ERegType
    Dim sName As String, lNLen As Long, lNMaxLen As Long
    Dim lBLen As Long, sBuffer As String, lBuffer As Long, bBuffer() As Byte
    Dim col As New Collection, clsValue As CVWValue
    
    lR = RegOpenKeyEx(Level, Path, 0, KEY_READ, hKey)
    If lR = ERROR_SUCCESS Then
        lR = RegQueryInfoKey(hKey, vbNullString, ByVal 0&, 0, ByVal 0&, ByVal 0&, ByVal 0&, ByVal 0&, lNMaxLen, ByVal 0&, ByVal 0&, ByVal 0&)
        If lR = ERROR_SUCCESS Then
            lIndex = 0
            Do
                Set clsValue = New CVWValue
                lNLen = lNMaxLen + 1
                sName = Space$(lNLen)
                lBLen = 0
                lR = RegEnumValue(hKey, lIndex, sName, lNLen, 0, enmRegTyp, ByVal 0&, lBLen)
                If lR = ERROR_NO_MORE_ITEMS Then Exit Do
                lNLen = lNMaxLen + 1
                If lR = ERROR_SUCCESS Then
                    Select Case enmRegTyp
                        Case REG_SZ, REG_EXPAND_SZ, REG_MULTI_SZ
                            lBLen = lBLen + 2
                            sBuffer = Space$(lBLen)
                            lR = RegEnumValue(hKey, lIndex, sName, lNLen, 0, enmRegTyp, ByVal sBuffer, lBLen)
                            If lR = ERROR_SUCCESS Then
                                If lBLen = 0 Then
                                    clsValue.Value = ""
                                Else
                                    clsValue.Value = Left$(sBuffer, lBLen - 1)
                                End If
                            End If
                        Case REG_BINARY
                            ReDim bBuffer(lBLen - 1)
                            lR = RegEnumValue(hKey, lIndex, sName, lNLen, 0, enmRegTyp, bBuffer(0), lBLen)
                            If lR = ERROR_SUCCESS Then
                                clsValue.Value = bBuffer
                            End If
                        Case REG_DWORD
                            lR = RegEnumValue(hKey, lIndex, sName, lNLen, 0, enmRegTyp, lBuffer, lBLen)
                            If lR = ERROR_SUCCESS Then
                                clsValue.Value = lBuffer
                            End If
                    End Select
                    If lR = ERROR_SUCCESS Then
                        clsValue.Name = Left$(sName, lNLen)
                        col.Add clsValue
                    End If
                End If
                lIndex = lIndex + 1
            Loop
        End If
        RegCloseKey hKey
    End If
    Set Values = col
End Function

Public Function Keys(ByVal Level As ERegLevel, _
                     ByVal Path As String _
                    ) As Collection
    'Gibt alle (Unter)-Schlüssel eines Pfades der Windows-Registierungsdatenbank zurück
    'Eingabe:
    '  Level: Bereich der Registrierung
    '  Path: Pfad des Eintrags (Name des Schlüssels)
    'Ausgabe:
    '  Keys: Collection mit den Schlüsseln (Strings)
    
    Dim hKey As Long, lR As Long, lIndex As Long
    Dim sName As String, lNLen As Long, lNMaxLen As Long
    Dim lBLen As Long, sBuffer As String, lBuffer As Long, bBuffer() As Byte
    Dim col As New Collection
    Dim uFileTime As FILETIME
    
    lR = RegOpenKeyEx(Level, Path, 0, KEY_READ, hKey)
    If lR = ERROR_SUCCESS Then
        lR = RegQueryInfoKey(hKey, vbNullString, ByVal 0&, 0, ByVal 0&, lNMaxLen, ByVal 0&, ByVal 0&, ByVal 0&, ByVal 0&, ByVal 0&, ByVal 0&)
        If lR = ERROR_SUCCESS Then
            lIndex = 0
            Do
                lNLen = lNMaxLen + 1
                sName = Space$(lNLen)
                lBLen = 0
                lR = RegEnumKeyEx(hKey, lIndex, sName, lNLen, 0, vbNullString, ByVal 0&, uFileTime)
                If lR = ERROR_NO_MORE_ITEMS Then Exit Do
                If lR = ERROR_SUCCESS Then
                    col.Add Left$(sName, lNLen)
                End If
                lIndex = lIndex + 1
            Loop
        End If
        RegCloseKey hKey
    End If
    Set Keys = col
End Function

Public Function DeleteValue(ByVal Level As ERegLevel, _
                            ByVal Path As String, _
                            ByVal Name As String _
                           ) As Boolean
    'Entfernt einen Wert aus der Windows-Registierungsdatenbank
    'Eingabe:
    '  Level: Bereich der Registrierung
    '  Path: Pfad des Eintrags
    '  Name: Name des Eintrags
    'Ausgabe:
    '  DeleteValue: True=Wert gelöscht
    '               False=Fehler, Wert nicht gelöscht
    
    Dim hKey As Long, lR As Long
    
    DeleteValue = False
    lR = RegOpenKeyEx(Level, Path, 0, KEY_SET_VALUE, hKey)
    Select Case lR
        Case ERROR_SUCCESS
            lR = RegDeleteValue(hKey, Name)
            If lR = ERROR_SUCCESS Or lR = ERROR_FILE_NOT_FOUND Then
                DeleteValue = True
            End If
            RegCloseKey hKey
        Case ERROR_FILE_NOT_FOUND
            DeleteValue = True
    End Select
End Function

Public Function DeleteKey(ByVal Level As ERegLevel, _
                          ByVal Path As String _
                         ) As Boolean
    'Entfernt einen kompletten Schlüssel (inkl. Werte und Unterschlüssel)
    'aus der Windows-Registierungsdatenbank
    'Eingabe:
    '  Level: Bereich der Registrierung
    '  Path: Pfad des Schlüssels
    'Ausgabe:
    '  DeleteKey: True=Schlüssel gelöscht
    '             False=Fehler, Schlüssel nicht gelöscht
    
    Dim hKey As Long, lR As Long
    
    On Error Resume Next
    DeleteKey = False
    lR = RegOpenKeyEx(Level, vbNullString, 0, KEY_SET_VALUE, hKey)
    If lR = ERROR_SUCCESS Then
        'Diese Funktion funktiert nur unter Win 95/98
        lR = RegDeleteKey(hKey, Path)
        If Err.Number Then
            'Diese Funktion funktioniert nur unter Win 98/2000
            'oder Win 95/NT mit IE4.0
            lR = SHDeleteKey(hKey, Path)
        End If
        If lR = ERROR_SUCCESS Or lR = ERROR_FILE_NOT_FOUND Then
            DeleteKey = True
        End If
        RegCloseKey hKey
    End If
    Err.Clear
End Function