VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "clsRegistry"
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Private Declare Function RegQueryValueExString Lib _
    "advapi32.dll" 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 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 RegCreateKey Lib _
    "advapi32.dll" Alias "RegCreateKeyA" _
    (ByVal hKey As Long, _
    ByVal lpSubKey As String, _
    phkResult 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 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 Any) _
    As Long
Private Const STANDARD_RIGHTS_ALL = &H1F0000
Private Const SYNCHRONIZE = &H100000
Private Const REG_BINARY = 3
Private Const REG_SZ = 1
Private Const KEY_QUERY_VALUE = &H1
Private Const KEY_SET_VALUE = &H2
Private Const KEY_CREATE_SUB_KEY = &H4
Private Const KEY_NOTIFY = &H10
Private Const KEY_EVENT = &H1
Private Const KEY_ENUMERATE_SUB_KEYS = &H8
Private Const KEY_CREATE_LINK = &H20
Private 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))
Private Const HKEY_USERS = &H80000003
Private Const HKEY_CURRENT_USER = &H80000001
Private Const HKEY_LOCAL_MACHINE = &H80000002
Private Const ERROR_NO_MORE_ITEMS = 259&
Private myWert As String, myWertInhalt As String
Private myZweig As Long, mySchlüsselpfad As String
Private iWertBinary As Boolean
Private Sub iWertLesen()
Dim Zweig As Long, Schlüsselinhalt As String
Dim Länge As Long, dummy, Schlüsselhandle As Long, Typ&
    myWertInhalt = ""
    Zweig = getZweig
    'Schlüssel öffnen, Handle holen
    dummy = RegOpenKeyEx(Zweig, mySchlüsselpfad, 0&, _
        KEY_QUERY_VALUE, Schlüsselhandle)
    If dummy <> 0 Then GoTo fehlerbehandlung
    'Länge ermitteln
    RegQueryValueExString Schlüsselhandle, myWert, 0&, _
        Typ, Schlüsselinhalt, Länge
    'Überprüfen, ob der Wert ein String ist
    If (Typ = REG_SZ) And (Länge > 0) Then
        'Puffer erzeugen
        Schlüsselinhalt = String(Länge, 0)
        'String holen
        RegQueryValueExString Schlüsselhandle, myWert, 0&, _
            Typ, Schlüsselinhalt, Länge
        myWertInhalt = Left(Schlüsselinhalt, Länge - 1)
    End If
fehlerbehandlung:
    RegCloseKey Schlüsselhandle
End Sub
Private Sub iWertSchreiben()
Dim Zweig As Long
Dim Länge As Long, dummy, Schlüsselhandle As Long, Typ&
    Zweig = getZweig
    'Schlüssel öffnen, Handle holen
    dummy = RegOpenKeyEx(Zweig, mySchlüsselpfad, 0&, _
        KEY_ALL_ACCESS, Schlüsselhandle)
    'Überprüfen, ob der Wert ein String ist
    If dummy <> 0 Then GoTo fehlerbehandlung
    'String schreiben
    RegSetValueEx Schlüsselhandle, myWert, _
        0&, REG_SZ, ByVal myWertInhalt, Len(myWertInhalt)
fehlerbehandlung:
    RegCloseKey Schlüsselhandle
End Sub

Private Function iWertLöschen() As Boolean
Dim Zweig As Long, Schlüsselinhalt As String
Dim Länge As Long, dummy, Schlüsselhandle As Long, Typ&
    Zweig = getZweig
    'Schlüssel öffnen, Handle holen
    dummy = RegOpenKeyEx(Zweig, mySchlüsselpfad, 0&, _
        KEY_ALL_ACCESS, Schlüsselhandle)
    If dummy = 0 Then 'Schlüssel ist vorhanden
        'Wert löschen
        dummy = RegDeleteValue(Schlüsselhandle, myWert)
        'Wenn Rückgabewert <>0, dann Fehler
        If dummy = 0 Then iWertLöschen = True
    End If
fehlerbehandlung:
    RegCloseKey Schlüsselhandle
End Function
Private Function iSchlüsselLöschenEx(Optional Hauptschlüssel As String)
Dim Zweig As Long, dummy, Schlüsselhandle As Long
Dim SName As String, Länge As Long
Dim actSchlüssel As String
Zweig = getZweig
If Hauptschlüssel = "" Then Hauptschlüssel = mySchlüsselpfad
'Schlüssel öffnen, Handle holen
dummy = RegOpenKeyEx(Zweig, Hauptschlüssel, 0&, _
    KEY_ALL_ACCESS, Schlüsselhandle)
If dummy = 0 Then
    SName = String(255, 0) 'Puffer erzeugen
    Länge = Len(SName) 'Länge des Puffers
    'Ersten Unterschlüssel ermitteln
    dummy = RegEnumKeyEx(Schlüsselhandle, 0, SName, Länge, _
        ByVal 0&, vbNullString, ByVal 0&, ByVal 0&)
    Do 'Alle Unterschlüssel dieser Ebene durchlaufen
        'Keine Unterschlüssel da, Schleife verlassen
        If dummy = ERROR_NO_MORE_ITEMS Then Exit Do
        'Name des Unterschlüssels
        actSchlüssel = Left(SName, Länge)
        'Rekursiv aufrufen, um alle Unterschlüssel
        'dieses Schlüssels zu löschen
        iSchlüsselLöschenEx Hauptschlüssel & "\" & actSchlüssel
        'erst jetzt kann dieser Schlüssel gelöscht werden
        RegDeleteKey Schlüsselhandle, actSchlüssel
        SName = String(255, 0) 'Puffer erzeugen
        Länge = Len(SName) 'Länge des Puffers
        'Nächster Unterschlüssel, aber auch mit Index 0,
        'da vorher schon ein Schlüssel gelöscht wurde
        dummy = RegEnumKeyEx(Schlüsselhandle, 0, SName, Länge, _
            ByVal 0&, vbNullString, ByVal 0&, ByVal 0&)
    Loop
    'Handle schließen
    RegCloseKey Schlüsselhandle
    'Aus dem Pfad den eigentlich übergebenen Schlüssel holen
    actSchlüssel = GetUnterschlüssel(Hauptschlüssel)
    'Den übergeordneten Pfad des Schlüssels holen
    Hauptschlüssel = Left(Hauptschlüssel, _
        Len(Hauptschlüssel) - 1 - Len(actSchlüssel))
    'Schlüssel öffnen, Handle holen
    dummy = RegOpenKeyEx(Zweig, Hauptschlüssel, 0&, _
        KEY_ALL_ACCESS, Schlüsselhandle)
    'Jetzt wird der eigentlich übergebene Schlüssel gelöscht
    'Vorher wurden nur Unterschlüssel gelöscht
    If dummy = 0 Then RegDeleteKey Schlüsselhandle, actSchlüssel
End If
fehlerbehandlung:
    RegCloseKey Schlüsselhandle
End Function
Private Function iSchlüsselAnlegenEx() As Boolean
Dim Zweig As Long, dummy, Schlüsselhandle As Long, Typ&
Dim strSchlüssel As String, strSchlüsselVorher As String, arrSchlüssel, i As Long
    Zweig = getZweig
    'Den Schlüsselpfad in Einzelschlüssel Splitten
    arrSchlüssel = SplitVBA(mySchlüsselpfad, "\")
    For i = 1 To UBound(arrSchlüssel)
        'Beginnend mit dem ersten Schlüssel aus dem
        'Array den Pfad aufbauen.
        strSchlüssel = strSchlüssel & arrSchlüssel(i)
        'Schlüssel öffnen, Handle holen
        dummy = RegOpenKeyEx(Zweig, strSchlüssel, 0&, _
            KEY_ALL_ACCESS, Schlüsselhandle)
        If dummy <> 0 Then 'Schlüssel fehlt, erst anlegen
            'Schlüssel öffnen, Handle holen
            dummy = RegOpenKeyEx(Zweig, strSchlüsselVorher, 0&, _
                KEY_ALL_ACCESS, Schlüsselhandle)
            'Schlüssel anlegen
            RegCreateKey Schlüsselhandle, arrSchlüssel(i), dummy
            If dummy <> 0 Then
                'Handle schließen
                RegCloseKey dummy
            Else
                'Schlüssel kann nicht angelegt werden
                GoTo fehlerbehandlung
            End If
        End If
        'Handle schließen
        RegCloseKey Schlüsselhandle
        strSchlüsselVorher = strSchlüssel
        strSchlüssel = strSchlüssel & "\"
    Next 'nächste Ebene
'Schlüssel wurde erfolgreich angelegt
iSchlüsselAnlegenEx = True
Exit Function
fehlerbehandlung:
    RegCloseKey Schlüsselhandle
End Function

Public Property Get Key_LocalMachine() As Boolean
    If myZweig = 0 Then Key_LocalMachine = True
    'Zweig ist HKEY_LOCAL_MACHINE
End Property
Public Property Let Key_LocalMachine(ByVal vNewValue As Boolean)
    If vNewValue Then myZweig = 0
    'Zweig ist HKEY_LOCAL_MACHINE
End Property
Public Property Get Key_CurrentUser() As Boolean
    If myZweig = 1 Then Key_CurrentUser = True
    'Zweig ist HKEY_CURRENT_USER
End Property
Public Property Let Key_CurrentUser(ByVal vNewValue As Boolean)
    If vNewValue Then myZweig = 1
    'Zweig ist HKEY_CURRENT_USER
End Property
Public Property Get Key_Users() As Boolean
    If myZweig = 2 Then Key_Users = True
    'Zweig ist HKEY_USERS
End Property
Public Property Let Key_Users(ByVal vNewValue As Boolean)
    If vNewValue Then myZweig = 2
    'Zweig ist HKEY_USERS
End Property

Public Property Get Wertinhalt() As String
    'Wertinhalt liefern
    iWertLesen
   Wertinhalt = myWertInhalt
End Property
Public Property Let Wertinhalt(ByVal vNewValue As String)
    'Wertinhalt setzen
    myWertInhalt = vNewValue
    iWertSchreiben
End Property
Public Property Get Schlüssel() As String
    'Pfad des Schlüssel
    Schlüssel = mySchlüsselpfad
End Property
Public Property Let Schlüssel(ByVal vNewValue As String)
    'Pfad des Schlüssel
    mySchlüsselpfad = vNewValue
End Property
Public Property Let Wertname(ByVal vNewValue As String)
    myWert = vNewValue
End Property
Public Property Get Wertname() As String
    Wertname = myWert
End Property
Public Function WertLöschen(Optional PfadZumWert As String) As Boolean
    If PfadZumWert <> "" Then
        myWert = GetUnterschlüssel(PfadZumWert)
        mySchlüsselpfad = Left(PfadZumWert, Len(PfadZumWert) - 1 - Len(myWert))
    End If
    WertLöschen = iWertLöschen()
End Function
Public Function SchlüsselAnlegen(Optional Schlüsselname As String) As Boolean
    If Schlüsselname <> "" Then
        myWert = vbNullString
        mySchlüsselpfad = Schlüsselname
    End If
    SchlüsselAnlegen = iSchlüsselAnlegenEx()
End Function
Public Function SchlüsselLöschen(Optional Schlüsselname As String) As Boolean
    If Schlüsselname <> "" Then
        myWert = vbNullString
        mySchlüsselpfad = Schlüsselname
    End If
    SchlüsselLöschen = iSchlüsselLöschenEx()
End Function
Private Function GetUnterschlüssel(Pfad)
Dim a As Long
Do
    If InStr(a + 1, Pfad, "\") Then _
        a = InStr(a + 1, Pfad, "\") _
        Else _
        Exit Do
Loop
GetUnterschlüssel = Right$(Pfad, Len(Pfad) - a)
End Function
Private Function SplitVBA(ByVal strText As String, Trenner As String)
Dim a As Long, b As Long, c()
Do
    b = InStr(1, strText, Trenner)
    ReDim Preserve c(1 To a + 1)
    If b = 0 Then c(a + 1) = strText: Exit Do
    c(a + 1) = Left$(strText, b - 1)
    strText = Right$(strText, Len(strText) - b)
    a = a + 1
Loop
SplitVBA = c
End Function
Private Function getZweig()
Select Case myZweig
    Case 0
        getZweig = HKEY_LOCAL_MACHINE
    Case 1
        getZweig = HKEY_CURRENT_USER
    Case 2
        getZweig = HKEY_USERS
End Select
End Function