Tipp 033: Die Windows-Registry verwenden

CommandButton            cmdEnumInfos
CommandButton            cmdEnumInfos
CommandButton            cmdRegistry
CommandButton            cmdRegistry
CommandButton            cmdRegistry
CommandButton            cmdRegistry
CommandButton            cmdRegistry
CommandButton            cmdRegistry
CommandButton            cmdRegistry
Form                     frmRegistry
Label                    lblNumVal
Label                    lblString
Line                     Line1
ListBox                  lstRegistry
TextBox                  txtNumVal

' VISUAL BASIC WORLD
' ===========================================
' Das große Portal zum Thema Visual Basic.
'
' Wenn Ihnen dieser Source Code gefallen hat,
' dann empfehlen Sie Visual Basic World bitte
' weiter und/oder setzen Sie einen Link auf:
'
' http://www.visualbasicworld.de/
'
' Vernetzen Sie sich mit uns:
'
' http://twitter.com/visualbasicwrld
'
' Autor: Joern Wittek [http://www.abgaenger2001.net]

 
Option Explicit
 
Private WithEvents Registry As clsRegistry
Attribute Registry.VB_VarHelpID = -1

Private Sub Registry_EnumKey(sSubKeyName As String)
 
   lstRegistry.AddItem sSubKeyName
 
End Sub

Private Sub Registry_EnumValue(sValueName As String, _
   vValueSetting As Variant, lValueType As Long)
 
   lstRegistry.AddItem sValueName & vbTab & vValueSetting _
      & vbTab & lValueType
 
End Sub

Private Sub cmdEnumInfos_Click(Index As Integer)
 
Dim Test As String
 
   lstRegistry.Clear
 
   Select Case Index
 
      Case 0
         Registry.EnumKeys lKeyRoot.HKEY_CURRENT_USER, _
            "Software"
 
      Case 1
         Registry.EnumValues lKeyRoot.HKEY_CURRENT_USER, _
            "Software\Microsoft\VBA\Microsoft Visual Basic"
 
   End Select
 
End Sub

Private Sub cmdRegistry_Click(Index As Integer)
 
   Select Case Index
 
      Case 0
         Registry.CreateKey lKeyRoot.HKEY_CURRENT_USER, _
            "Neuer Schlüssel"
 
         Case 1
            If IsNumeric(txtNumVal.Text) = True Then _
               Registry.SetNumericValue lKeyRoot.HKEY_CURRENT_USER, _
               "Neuer Schlüssel", "NumValue", txtNumVal.Text
 
            Case 2
               lblNumVal.Caption = _
               Registry.QueryNumericValue(lKeyRoot.HKEY_CURRENT_USER, _
               "Neuer Schlüssel", "NumValue")
 
         Case 3
            Registry.SetStringValue lKeyRoot.HKEY_CURRENT_USER, _
            "Neuer Schlüssel", "StrValue", txtString.Text
 
            Case 4
               lblString.Caption = _
               Registry.QueryStringValue(lKeyRoot.HKEY_CURRENT_USER, _
               "Neuer Schlüssel", "StrValue")
 
         Case 5
            Registry.EnableDelete = True
               Registry.DeleteValue lKeyRoot.HKEY_CURRENT_USER, _
               "Neuer Schlüssel", "StrValue"
 
            Registry.EnableDelete = True
               Registry.DeleteValue lKeyRoot.HKEY_CURRENT_USER, _
               "Neuer Schlüssel", "NumValue"
 
      Case 6
         Registry.EnableDelete = True
         Registry.DeleteKey lKeyRoot.HKEY_CURRENT_USER, "Neuer Schlüssel"
 
   End Select
 
End Sub

Private Sub Form_Load()
 
   Set Registry = New clsRegistry
 
   lblNumVal.Caption = ""
   lblString.Caption = ""
 
End Sub

' VISUAL BASIC WORLD
' ===========================================
' Das große Portal zum Thema Visual Basic.
'
' Wenn Ihnen dieser Source Code gefallen hat,
' dann empfehlen Sie Visual Basic World bitte
' weiter und/oder setzen Sie einen Link auf:
'
' http://www.visualbasicworld.de/
'
' Vernetzen Sie sich mit uns:
'
' http://twitter.com/visualbasicwrld
'
' Autor: Joern Wittek [http://www.abgaenger2001.net]
'
' +-----------------------------------------+
' | Klasse für Zugriff auf die Registry von |
' |      Windows 9x (nicht Windows NT)      |
' +-----------------------------------------+
' |           Copyright 2001 by:            |
' |          Abgänger 2001 Online           |
' +-----------------------------------------+

 
Option Explicit
 
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 tSecurity_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 tFileTime) 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, _
   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 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 RegQueryValueExLong Lib "advapi32.dll" _
   Alias "RegQueryValueExA" ( _
   ByVal hKey As Long, _
   ByVal lpValueName As String, _
   ByVal lpReserved As Long, _
   lpType As Long, _
   lpData As Long, lpcbData As Long) As Long
 
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 RegSetValueExLong Lib "advapi32.dll" _
   Alias "RegSetValueExA" ( _
   ByVal hKey As Long, _
   ByVal lpValueName As String, _
   ByVal Reserved As Long, _
   ByVal dwType As Long, _
   lpValue As Long, _
   ByVal cbData As Long) As Long
 
Private Declare Function RegSetValueExString Lib "advapi32.dll" _
   Alias "RegSetValueExA" ( _
   ByVal hKey As Long, _
   ByVal lpValueName As String, _
   ByVal Reserved As Long, _
   ByVal dwType As Long, _
   ByVal lpValue As String, _
   ByVal cbData As Long) As Long
 
Public Event EnumKey(sSubKeyName As String)
   'Tritt für jeden gefundenen Schlüssel auf.
 
Public Event EnumKeyComplete()
   'Tritt auf, wenn Schlüsselenumeration abgeschlossen.
 
Public Event EnumValue(sValueName As String, _
   vValueSetting As Variant, lValueType As Long)
      'Tritt für jeden gefundenen Wert auf.
 
Public Event EnumValueComplete()
   'Tritt auf, wenn Werteenumeration abgeschlossen.
 
Public Event RegistryError(ErrorCode As Long)
   'Tritt auf, wenn beim Zugriff ein Fehler auftrat
 
Private mbEnableDelete As Boolean 'Löschen erlaubt
 
Private Const REG_OPTION_NON_VOLATILE = 0
   'Schlüssel bleibt beim Neustart erhalten
 
Private Const READ_CONTROL = &H20000
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_NOTIFY = &H10
Private Const KEY_CREATE_LINK = &H20
Private Const KEY_READ = KEY_QUERY_VALUE + _
   KEY_ENUMERATE_SUB_KEYS + KEY_NOTIFY + READ_CONTROL
Private Const KEY_WRITE = KEY_SET_VALUE + _
   KEY_CREATE_SUB_KEY + READ_CONTROL
Private Const KEY_EXECUTE = KEY_READ
Private Const KEY_ALL_ACCESS = KEY_QUERY_VALUE + _
   KEY_SET_VALUE + KEY_CREATE_SUB_KEY + _
   KEY_ENUMERATE_SUB_KEYS + KEY_NOTIFY + KEY_CREATE_LINK + _
   READ_CONTROL
 
'Zugriffsoptionen:
'Da aus Gründen der Kompaktheit dieses Klassenmoduls eine
'gemeinsamgenutze Prozedur zum Öffnen eines Schlüssels
'deshalb werden nicht die spezifizierten, sondern nur
'KEY_ALL_ACCESS genutzt.
 
'--- Datentypen ---'
Public Enum lValueType
    REG_SZ = 1
    REG_DWORD = 4
End Enum
 
'---  Fehlercodes ---'
Public Enum lErrorCode
    REG_ERROR_SUCCESS = 0
    REG_ERROR_BADKEY = 2
    REG_ERROR_CANTOPEN = 3
    REG_ERROR_CANTREAD = 4
    REG_ERROR_CANTWRITE = 5
    REG_ERROR_OUTOFMEMORY = 6
    REG_ERROR_INVALID_PARAMETER = 7
    REG_ERROR_ACCESS_DENIED = 8
    REG_ERROR_INVALID_PARAMETERS = 87
    REG_ERROR_MORE_DATA = 234
    REG_ERROR_NO_MORE_ITEMS = 259
End Enum
 
'--- Basen ---'
Public Enum lKeyRoot
    HKEY_CLASSES_ROOT = &H80000000
    HKEY_CURRENT_USER = &H80000001
    HKEY_LOCAL_MACHINE = &H80000002
    HKEY_USERS = &H80000003
    HKEY_PERFORMANCE_DATA = &H80000004
    HKEY_CURRENT_CONFIG = &H80000005
    HKEY_DYN_DATA = &H80000006
End Enum
 
'--- Filetime-Typ ---'
Private Type tFileTime
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type
 
'--- SecurityAttributes-Typ ---'
Private Type tSecurity_Attributes
    lLength As Long
    lSecurityDescriptor As Long
    bInheritHandle As Boolean
End Type
Public Property Let EnableDelete(ByVal ubNewValue As Boolean)
    'Setzt das Flag zum Löschen von Werten und Schlüsseln
 
    mbEnableDelete = ubNewValue
 
End Property
Public Property Get EnableDelete() As Boolean
    'Liest das Flag zum Löschen von Werten und Schlüsseln
 
    EnableDelete = mbEnableDelete
 
End Property

Public Sub CreateKey(lKeyRoot As Long, sKeyName As String)
    'Legt einen Schlüssel neu an und öffnet ihn.
 
    Dim hKey As Long
    Dim lRetVal As Long
    Dim tScAttr As tSecurity_Attributes
 
    tScAttr.lLength = 50
    tScAttr.lSecurityDescriptor = 0
    tScAttr.bInheritHandle = True
 
    lRetVal = RegCreateKeyEx(lKeyRoot, sKeyName, 0&, _
      vbNullString, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, _
      tScAttr, hKey, lRetVal)
 
    If lRetVal <> REG_ERROR_SUCCESS Then
        RaiseEvent RegistryError(lRetVal)
    End If
 
    RegCloseKey (hKey)
 
End Sub

Public Sub DeleteKey(lKeyRoot As Long, sKeyName As String)
    'Löscht einen Schlüssel (Benötigt EnableDelete = True)
 
    'ACHTUNG! DIESE METHODE RÄUMT JEDEN SCHLÜSSEL RADIKAL LEER!
    'NUR MIT ÄUßERSTER VORSICHT EINSETZEN! BEI UNSACHGEMÄßER
    'VERWENDUNG KANN DAS WINDOWS-SYSTEM BESCHÄDIGT WERDEN!
    'WIR ÜBERNEHME KEINE HAFTUNG!
 
    'Hinweis: Unter Windows NT müssen zuerst alle Unterschlüssel,
    'sofern vorhanden, entfernt werden, damit die DeleteKey-Methode
    'fehlerfrei ausgeführt wird.
 
    Dim lRetVal As Long
 
    If mbEnableDelete = True Then
        lRetVal = RegDeleteKey(lKeyRoot, sKeyName)
 
        If lRetVal <> REG_ERROR_SUCCESS Then
            RaiseEvent RegistryError(lRetVal)
        End If
    End If
 
    mbEnableDelete = False
 
End Sub

Public Sub DeleteValue(lKeyRoot As Long, sKeyName As String, _
   sValueName As String)
    'Löscht einen Wert (Benötigt EnableDelete = True)
 
    Dim hKey As Long
    Dim lRetVal As Long
 
    If (OpenKey(lKeyRoot, sKeyName, hKey) = True) And _
      (mbEnableDelete = True) Then
 
        lRetVal = RegDeleteValue(hKey, sValueName)
 
        If lRetVal <> REG_ERROR_SUCCESS Then
            RaiseEvent RegistryError(lRetVal)
        End If
    End If
 
    lRetVal = RegCloseKey(hKey)
    mbEnableDelete = False
 
End Sub

Public Function EnumKeys(lKeyRoot As Long, sKeyName As String)
    'Ruft für jeden gefundenen Unterschlüssel das Ereignis
    'EnumKeys(<Name>) auf. Wenn keine weitern Unterschlüssel
    'existieren, wird das Ereignis EnumValueComplete ausgelöst.
 
    Dim hKey As Long
    Dim lCurIndex As Long
    Dim lRetVal As Long
    Dim lSubKeyNameLen As Long
    Dim sSubKeyName As String
    Dim tFileTime As tFileTime
 
    If OpenKey(lKeyRoot, sKeyName, hKey) = True Then
        lCurIndex = 0
 
        Do
            lSubKeyNameLen = 1024
            sSubKeyName = String(lSubKeyNameLen, Chr(32))
 
            lRetVal = RegEnumKeyEx(hKey, lCurIndex, sSubKeyName, _
               lSubKeyNameLen, 0, vbNullChar, vbNull, tFileTime)
 
            If lRetVal = REG_ERROR_SUCCESS Then
                sSubKeyName = Left(sSubKeyName, lSubKeyNameLen)
                RaiseEvent EnumKey(sSubKeyName)
            End If
 
            lCurIndex = lCurIndex + 1
        Loop While lRetVal <> REG_ERROR_NO_MORE_ITEMS
 
        RaiseEvent EnumKeyComplete
    End If
 
    lRetVal = RegCloseKey(hKey)
 
End Function

Public Function EnumValues(lKeyRoot As Long, sKeyName As String)
    'Ruft für jeden gefundenen Wert das Ereignis
    'EnumValue(<Name>,<Wert>,<Typ>) auf. Wenn keine weiteren
    'Werte vorliegen wird das Ereignis EnumValueComplete ausgelöst.
 
    Dim hKey As Long
    Dim lCurIndex As Long
    Dim lDWORD As Long
    Dim lRetVal As Long
    Dim lValueNameLen As Long
    Dim lValueSettingLen As Long
    Dim lValueType As Long
    Dim sValueName As String
    Dim sValueSetting As String
    Dim vValueSetting As Variant
 
    If OpenKey(lKeyRoot, sKeyName, hKey) = True Then
        lCurIndex = 0
 
        Do
            lValueNameLen = 1024
            lValueSettingLen = 1024
            sValueName = String(lValueNameLen, Chr(32))
            sValueSetting = String(lValueSettingLen, Chr(32))
 
            lRetVal = RegEnumValue(hKey, lCurIndex, sValueName, _
               lValueNameLen, 0, lValueType, sValueSetting, _
               lValueSettingLen)
 
            If lRetVal = REG_ERROR_SUCCESS Then
                sValueName = Left(sValueName, lValueNameLen)
 
                Select Case lValueType
 
                    Case REG_SZ
                        vValueSetting = Left(sValueSetting, _
                           lValueSettingLen - 1)
                    Case REG_DWORD
                        vValueSetting = QueryNumericValue( _
                        lKeyRoot, sKeyName, sValueName)
 
                End Select
 
                RaiseEvent EnumValue(sValueName, vValueSetting, _
                lValueType)
 
            Else
                RaiseEvent RegistryError(lRetVal)
 
                lRetVal = RegCloseKey(hKey)
 
                  Exit Function
 
            End If
 
            lCurIndex = lCurIndex + 1
        Loop While lRetVal <> REG_ERROR_NO_MORE_ITEMS
 
        RaiseEvent EnumValueComplete
    End If
 
    lRetVal = RegCloseKey(hKey)
 
End Function

Private Function OpenKey(lKeyRoot As Long, sKeyName As String, _
   hKey As Long) As Boolean
    'Öffnet einen Schlüssel zur weiteren Verwendung
    'durch andere Methoden.
 
    Dim lRetVal As Long
 
    OpenKey = False
 
    lRetVal = RegOpenKeyEx(lKeyRoot, sKeyName, 0, _
      KEY_ALL_ACCESS, hKey)
 
    Select Case lRetVal
 
        Case REG_ERROR_SUCCESS
            OpenKey = True
 
        Case REG_ERROR_BADKEY
            CreateKey lKeyRoot, sKeyName
 
            lRetVal = RegOpenKeyEx(lKeyRoot, sKeyName, 0, _
               KEY_ALL_ACCESS, hKey)
 
            If lRetVal = REG_ERROR_SUCCESS Then
                OpenKey = True
 
            Else
                RaiseEvent RegistryError(REG_ERROR_CANTOPEN)
 
            End If
 
        Case Else
 
            RaiseEvent RegistryError(lRetVal)
 
    End Select
 
End Function

Public Function QueryNumericValue(lKeyRoot As Long, _
   sKeyName As String, sValueName As String) As Long
    'Liest einen Numerischen Wert
 
    QueryNumericValue = 0
 
    Dim hKey As Long
    Dim lRetVal As Long
    Dim lValueSetting
 
    If OpenKey(lKeyRoot, sKeyName, hKey) = True Then
        lRetVal = RegQueryValueExLong(hKey, sValueName, _
         0&, REG_DWORD, lValueSetting, 4)
 
        If lRetVal <> REG_ERROR_SUCCESS Then
 
            RaiseEvent RegistryError(lRetVal)
            lRetVal = RegCloseKey(hKey)
 
            Exit Function
 
        End If
 
        QueryNumericValue = lValueSetting
 
    End If
 
    lRetVal = RegCloseKey(hKey)
 
End Function

Public Function QueryStringValue(lKeyRoot As Long, _
   sKeyName As String, sValueName As String) As String
    'Liest einen String
 
    QueryStringValue = ""
 
    Dim hKey As Long
    Dim lRetVal As Long
    Dim lValueSettingType As Long
    Dim lValueSettingLength As Long
    Dim sValueSetting As String
 
    If OpenKey(lKeyRoot, sKeyName, hKey) = True Then
      lRetVal = RegQueryValueEx(hKey, sValueName, _
         0&, lValueSettingType, 0&, lValueSettingLength)
 
        If (lRetVal <> REG_ERROR_SUCCESS) And _
         (lRetVal <> REG_ERROR_MORE_DATA) Then
 
            RaiseEvent RegistryError(lRetVal)
            lRetVal = RegCloseKey(hKey)
 
               Exit Function
 
        End If
 
      sValueSetting = String(lValueSettingLength, vbNullChar)
      lRetVal = RegQueryValueExString(hKey, sValueName, _
         0&, lValueSettingType, sValueSetting, lValueSettingLength)
 
        If lRetVal <> REG_ERROR_SUCCESS Then
 
            RaiseEvent RegistryError(lRetVal)
            lRetVal = RegCloseKey(hKey)
 
               Exit Function
 
        End If
 
      QueryStringValue = Left(sValueSetting, _
         lValueSettingLength - 1)
 
    End If
 
    lRetVal = RegCloseKey(hKey)
 
End Function

Public Sub SetNumericValue(lKeyRoot As Long, _
   sKeyName As String, sValueName As String, lValueSetting As Long)
    'Setzt einen Numerischen Wert oder erzeugt ihn,
    'wenn er noch nicht existiert.
 
    Dim hKey As Long
    Dim lRetVal As Long
 
    If OpenKey(lKeyRoot, sKeyName, hKey) = True Then
        lRetVal = RegSetValueExLong(hKey, sValueName, _
        0&, REG_DWORD, lValueSetting, 4)
 
        If lRetVal = REG_ERROR_BADKEY Then
            RaiseEvent RegistryError(REG_ERROR_BADKEY)
        End If
 
    End If
 
    lRetVal = RegCloseKey(hKey)
 
End Sub

Public Sub SetStringValue(lKeyRoot As Long, sKeyName As String, _
   sValueName As String, sValueSetting As String)
      'Setzt einen String oder erzeugt ihn,
      'wenn er noch nicht existiert.
 
   Dim hKey As Long
   Dim lRetVal As Long
 
   If OpenKey(lKeyRoot, sKeyName, hKey) = True Then
      If sValueSetting = "" Then sValueSetting = Space(1)
         sValueSetting = sValueSetting & vbNullChar
 
      lRetVal = RegSetValueExString(hKey, sValueName, _
         0&, REG_SZ, sValueSetting, Len(sValueSetting))
 
      If lRetVal = REG_ERROR_BADKEY Then
         RaiseEvent RegistryError(REG_ERROR_BADKEY)
      End If
 
    End If
 

    lRetVal = RegCloseKey(hKey)
 
End Sub