Untitled

Zugriff auf die Registry

Um den Zugriff auf die Registry mittels API-Funktionen zu demonstrieren, habe ich mal eine kleine Klasse geschrieben, die den Zugriff kapselt. Ist nichts besonderes und erlaubt nur den Zugriff auf SZ Werte, die aber am häufigsten in der Registry vorkommen.
Schlüssel selbst können aber ohne Einschränkungen angelegt und gelöscht werden. Da es nicht funzt, Schlüssel zu löschen, die Unterschlüssel enthalten, werden vorher automatisch alle Unterschlüssel und deren Unterschlüssel ohne Rückfrage gelöscht.
Wie immer beim Arbeiten mit der Registry, muss äußerste Vorsicht gelten (Sicherheitskopie).
Jeder Fehler kann das System irepparabel schädigen.
Ich hoffe ja, dass mein Code soweit fehlerfrei ist, nur garantieren tue ich nichts. Aber keine Panik, bei mir ist es fehlerfrei gelaufen.
Beim Anlegen von Schlüsseln werden bei meiner Klasse alle fehlenden Schlüssel automatisch angelegt, falls sie noch nicht vorhanden sind.
Wenn mehr Funktionen und andere Datentypen gebraucht werden, gibt es im Inet komplette Freeware- dll's, die den Zugriff auf die Registry auf einfache Art ermöglichen
Bei http://www.gssg.de/ unter VisualBasic findest man z.B. so etwas.

Beispielklasse (Registry.cls 12 KB)

'Zur Demonstration in ein Modul

Sub SchlüsselAnlegen()
Dim a As New clsRegistry 'Neue Instanz der Klasse
a.Schlüssel = "Software\Microsoft\AAAAA\ABBBB\CCCCC\DDDDD\EEEEE"
a.SchlüsselAnlegen
End Sub

Sub SchlüsselLöschen()
Dim a As New clsRegistry 'Neue Instanz der Klasse
a.Schlüssel = "Software\Microsoft\AAAAA\ABBBB\CCCCC"
a.SchlüsselLöschen
End Sub

Sub WertAnlegen()
Dim a As New clsRegistry 'Neue Instanz der Klasse
a.Schlüssel = "SOFTWARE\Microsoft\AAAAA\ABBBB\Neuer Schlüssel #1"
a.SchlüsselAnlegen
'Schlüssel muss vorhanden sein
'a.Wertname = vbNullString 'Für den unbenannten Standardwert
a.Wertname = "Neuer Wert #3"
a.Wertinhalt = "1234567890"
End Sub

Sub WertAuslesen()
Dim a As New clsRegistry 'Neue Instanz der Klasse
'Schlüssel muss vorhanden sein
a.Schlüssel = "SOFTWARE\Microsoft\AAAAA\ABBBB\Neuer Schlüssel #1"
'a.Wertname = vbNullString 'Für den unbenannten Standardwert
a.Wertname = "Neuer Wert #3"
MsgBox a.Wertinhalt
End Sub

Sub WertLöschen()
Dim a As New clsRegistry 'Neue Instanz der Klasse
'Schlüssel muss vorhanden sein
a.Schlüssel = "SOFTWARE\Microsoft\AAAAA\ABBBB\Neuer Schlüssel #1"
a.Wertname = "Neuer Wert #3"
a.WertLöschen
End Sub

'##################################
'Und nun der Code der Klasse clsRegistry

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