Durchsuchen der Registry Durchsucht durch Enumerierung von Unterschlüsseln und Values, die Registry nach einem String.
Autor:   LonelySuicide666	Bewertung:     [ Jetzt bewerten ]	Views:  39.172
www.vbapihelpline.de	System:  Win9x, WinNT, Win2k, WinXP, Win7, Win8, Win10, Win11	Beispielprojekt auf CD

Geben Sie hier Ihre persönliche Bewertung ab! Anzahl Bewertungen bisher: 53 Bewertung insgesamt: gut Durchschnittliche Bewertung: 4.0 von 5 Sternen

sehr gut     gut     nützlich     mittelmäßig     mangelhaft

Unser heutiger Tipp ist ziemlich umfangreich und zeigt, wie man die Windows-Registrier-Datenbank nach einem bestimmten Wert oder auch Teilwert durchsuchen kann. Hierbei kann angegeben werden, ob nur in den Hauptschlüsseln oder auch in den Unterschlüsseln und Werten gesucht werden soll.

Am Ende der Suchroutine finden Sie dann ein kleines Beispielsprogramm.

Den nachfolgenden Code am besten in ein separates Modul "packen".

' zunächst die benötigten API-Deklarationen
Private Declare Function RegCloseKey Lib "advapi32.dll" ( _
  ByVal hKey As Long) 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 Byte, _
  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 RegEnumKey Lib "advapi32.dll" _
  Alias "RegEnumKeyA" ( _
  ByVal hKey As Long, _
  ByVal dwIndex As Long, _
  ByVal lpName As String, _
  ByVal cbName As Long) As Long
 
' Such-Methode
Public Enum CompareMode
  Exact = 0
  StringExists = 1
End Enum
 
' Suchoptionen
Public Type SearchOptions
  SearchString As String
  StartSearchPath As String
  SearchMainKey As MainKey
  HowToSearch As CompareMode
  SearchSubfolders As Boolean
  FindKeys As Boolean
  FindValueNames As Boolean
  FindValues As Boolean
End Type
 
' Zeitdaten
Private Type FILETIME
  dwLowDateTime As Long
  dwHighDateTime As Long
End Type
 
' KeyHandles der Hauptschlüssel
Public Enum MainKey
  HKEY_CLASSES_ROOT = &H80000000
  HKEY_CURRENT_CONFIG = &H80000005
  HKEY_CURRENT_USER = &H80000001
  ' Nur Windows 95, 98
  HKEY_DYN_DATA = &H80000006
  HKEY_LOCAL_MACHINE = &H80000002
  ' Nur Windows NT, 2000
  HKEY_PERFORMANCE_DATA = &H80000004
  HKEY_USERS = &H80000003
End Enum
 
Private Enum KeyAccess
  KEY_ALL_ACCESS = &HF003F
  KEY_CREATE_LINK = &H20
  KEY_CREATE_SUB_KEY = &H4
  KEY_ENUMERATE_SUB_KEYS = &H8
  KEY_EXECUTE = &H20019
  KEY_NOTIFY = &H10
  KEY_QUERY_VALUE = &H1
  KEY_READ = &H20019
  KEY_SET_VALUE = &H2
  KEY_WRITE = &H20006
End Enum
 
Private Enum ValueOpenMode
  REG_BINARY = 3
  REG_DWORD = 4
  REG_DWORD_BIG_ENDIAN = 5
  REG_DWORD_LITTLE_ENDIAN = 4
  REG_EXPAND_SZ = 2
  REG_LINK = 6
  REG_MULTI_SZ = 7
  REG_NONE = 0
  REG_RESOURCE_LIST = 8
  REG_SZ = 1
End Enum
 
Private RetVal As Long
 
' Wenn True dann wird die Suche gestoppt
Public StopSearch As Boolean
 
 
' Registry nach einem bestimmten String durchsuchen
' Options legt die Suchoptionen fest
Public Function FindString(ByRef Options As SearchOptions, _
  ByRef RetVar() As String)
 
  Dim TmpRetVar() As String
  Dim HKeyStart(6) As String
  Dim I As Integer
  Dim TmpStartPath As String
  Dim CheckString As String
  Dim CheckString2 As String
  Dim CheckString3 As String
 
  With Options
    TmpRetVar = Get_KeyValues(.SearchMainKey, _
      .StartSearchPath)
 
    For I = 0 To UBound(TmpRetVar)
      If StopSearch Then Exit Function
      DoEvents
      CheckString = Get_ValueString(.SearchMainKey, _
        .StartSearchPath, TmpRetVar(I))
      CheckString2 = TmpRetVar(I)
      CheckString3 = .StartSearchPath
      If InStr(1, CheckString3, "\") = 0 Then _
        CheckString3 = "\" & CheckString3
 
      ' EXAKTE ÜBEREINSTIMMUNG
      If .HowToSearch = Exact Then
 
        ' VALUE
        If .SearchString = CheckString And _
          .FindValues Then
          GoSub Ret_Add
 
        ' VALUENAME
        ElseIf .SearchString = CheckString2 And _
          .FindValueNames Then
          GoSub Ret_Add
 
        ' KEYNAME
        ElseIf .SearchString = CheckString3 Or _
          Mid$(CheckString3, InStrRev(CheckString3, _
          "\") + 1) = .SearchString And .FindKeys Then
          GoSub Ret_Add
        End If
 
      ' TEILSTRING
      ElseIf .HowToSearch = StringExists Then
        ' VALUE
        If InStr(1, StrConv(CheckString, vbUpperCase), _
          StrConv(.SearchString, vbUpperCase)) > 0 And _
          .FindValues Then
          GoSub Ret_Add
 
        ' VALUENAME
        ElseIf InStr(1, StrConv(CheckString2, vbUpperCase), _
          StrConv(.SearchString, vbUpperCase)) > 0 And _
          .FindValueNames Then
          GoSub Ret_Add
 
        ' KEYNAME
        ElseIf InStr(1, StrConv(CheckString3, vbUpperCase), _
          StrConv(.SearchString, vbUpperCase)) > 0 And _
          .FindKeys Then
          GoSub Ret_Add
        End If
      End If
    Next I
    On Error Resume Next
 
    ' ggf. auch Unterordner durchsuchen
    If .SearchSubfolders = True Then
      TmpRetVar = Get_SubFolders(.SearchMainKey, _
        .StartSearchPath)
      If TmpRetVar(0) = "" Then Exit Function
 
      ' für jeden Unterordner
      For I = 0 To UBound(TmpRetVar)
        If StopSearch Then Exit Function
        DoEvents
        TmpStartPath = .StartSearchPath
        If .StartSearchPath = "" Then
          .StartSearchPath = TmpRetVar(I)
        Else
          .StartSearchPath = .StartSearchPath & "\" & _
            TmpRetVar(I)
        End If
 
        ' Funktion ruft sich selbst auf
        FindString Options, RetVar
        .StartSearchPath = TmpStartPath
      Next I
    End If
  End With
  Exit Function
 
Ret_Add:
  On Error GoTo Err_ReDim1
  ReDim Preserve RetVar(0 To UBound(RetVar) + 1)
  On Error GoTo 0
  RetVar(UBound(RetVar)) = CheckString3 & vbCrLf & _
    CheckString2 & vbCrLf & CheckString
Return
 
Err_ReDim1:
    ReDim RetVar(0)
    Resume Next
End Function
 
' ValueNames Suchen
Public Function Get_KeyValues(ByVal hKey As MainKey, _
  ByVal StartFolder As String) As Variant
 
  Dim ValueStr As String
  Dim RetHandle As Long
  Dim ValueIndex As Long
  Dim RetVar() As String
  Dim DummiType As Long
  Dim DummiData(0 To 254) As Byte
 
  ReDim RetVar(0)
  RetVal = RegOpenKeyEx(hKey, StartFolder, 0&, _
    KeyAccess.KEY_QUERY_VALUE, RetHandle)
 
  ' Wenn der Key nicht geöffnet werden kann
  ' Funktion verlassen
  If RetVal <> 0 Then
    Get_KeyValues = RetVar
    Exit Function
  End If
 
  Do
    ValueStr = Space(255)
    ' Key enumerieren, den x-ten (ValueIndex)
    ' SubKey auslesen
    RetVal = RegEnumValue(RetHandle, ValueIndex, ValueStr, _
      Len(ValueStr), 0&, DummiType, DummiData(0), 256)
    If RetVal <> 0 Then Exit Do
 
    ReDim Preserve RetVar(0 To ValueIndex)
 
    ' Index für die nächste Suche erhöhen
    ValueIndex = ValueIndex + 1
    RetVar(UBound(RetVar)) = Left$(ValueStr, _
      InStr(1, ValueStr, vbNullChar) - 1)
  Loop
  RegCloseKey RetHandle
  Get_KeyValues = RetVar
End Function
 
' Sucht nach KeyNames
Public Function Get_SubFolders(ByVal hKey As MainKey, _
  ByVal StartFolder As String) As Variant
 
  Dim SubStr As String
  Dim RetHandle As Long
  Dim KeyIndex As Long
  Dim RetVar() As String
 
  ReDim RetVar(0)
  RetVal = RegOpenKeyEx(hKey, StartFolder, 0&, _
    KeyAccess.KEY_ENUMERATE_SUB_KEYS, RetHandle)
 
  ' Wenn der Key nicht geöffnet werden kann
  ' Funktion verlassen
  If RetVal <> 0 Then
    Get_SubFolders = RetVar
    Exit Function
  End If
 
  Do
    SubStr = Space(255)
    ' KeyNames enumerieren, den x-ten (KeyIndex)
    ' KeyName auslesen
    RetVal = RegEnumKey(RetHandle, KeyIndex, SubStr, _
      Len(SubStr))
    If RetVal <> 0 Then Exit Do
 
    ReDim Preserve RetVar(0 To KeyIndex)
 
    ' Index für die nächste Suche erhöhen
    KeyIndex = KeyIndex + 1
    RetVar(UBound(RetVar)) = Left$(SubStr, _
      InStr(1, SubStr, vbNullChar) - 1)
  Loop
  RegCloseKey RetHandle
 
  Get_SubFolders = RetVar
End Function
 
' Value wert von ValueName bekommen
Public Function Get_ValueString(ByVal hKey As MainKey, _
  ByVal StartFolder As String, ByVal ValueName As String) _
  As String
 
  Dim RetStr As String
  Dim RetHandle As Long
  Dim RetType  As Long
  Dim TmpVar() As Variant
 
  ' Key öffnen (für KeyHandle)
  RetVal = RegOpenKeyEx(hKey, StartFolder, 0&, _
    KeyAccess.KEY_QUERY_VALUE, RetHandle)
 
  ' Wenn der Key nicht geöffnet werden kann
  ' Funktion verlassen
  If RetVal <> 0 Then Exit Function
 
  ' Wert auslesen
  RetStr = Space(256)
  RetVal = RegQueryValueEx(RetHandle, ValueName, 0&, _
    RetType, ByVal RetStr, Len(RetStr))
  If RetVal <> 0 Then Exit Function
 
  ' Nur übergeben wenn gefundene Value ein String ist
  If RetType = REG_SZ Then
    Get_ValueString = Left$(RetStr, _
      InStr(1, RetStr, vbNullChar) - 1)
  End If
  RegCloseKey RetHandle
End Function

Und hier das Beispielsprogramm
Benötigt wird eine Form, eine Listbox, darunter ein Label-Steuerelement (Label2), sowie zwei Command-Schaltflächen (Starten und Stoppen). Beim Klicken auf "Starten" wird der Abschnitt HKEY_LOCAL_MACHINE nach dem Text ProductID durchsucht, wobei die Suche bei Software\Microsoft startet und alle Unterordner mit einbezogen werden. Alle Fundstellen werden in der Listbox angezeigt. Die Suche kann jederzeit über die 2. Schaltfläche abgebrochen werden.

' Starten der Suche
Private Sub Command1_Click()
  Dim SO As SearchOptions
  Dim Gefunden() As String
  Dim I As Integer
 
  Command1.Enabled = False
  List1.Clear
 
  With SO
    ' Exakte Suche
    .HowToSearch = StringExists
    ' Abschnitt "Locale Machine"
    .SearchMainKey = HKEY_LOCAL_MACHINE
    ' Nach ProductID
    .SearchString = "ProductID"
    ' Starten bei "Software\Microsoft"
    .StartSearchPath = "Software\Microsoft"
    ' Unterordner durchsuchen
    .SearchSubfolders = True
    ' Keine KeyNames suchen
    .FindKeys = True
    ' ValueNames Suchen
    .FindValueNames = True
    ' Keine Values Suchen
    .FindValues = True
  End With
 
  StopSearch = False
  Me.MousePointer = vbHourglass
  Label2.Caption = "Suche..."
  DoEvents
 
  ' Suche starten
  FindString SO, Gefunden
  Label2.Caption = "Einen moment bitte..."
  DoEvents
 
  ' Falls nichts gefunden
  On Error Resume Next
  For I = 0 To UBound(Gefunden)
    ' StartSearchPath durch ".." ersetzen
    ' und in die Lisbox übertragen
    List1.AddItem Replace(Gefunden(I), _
      SO.StartSearchPath, "..", 1, 1)
  Next I
  Label2.Caption = "Gefunden: " & List1.ListCount
  Command1.Enabled = True
  Me.MousePointer = vbNormal
End Sub
 
' Stoppen der Suche
Private Sub Command2_Click()
 StopSearch = True
End Sub