vb@rchiv
VB Classic
VB.NET
ADO.NET
VBA
C#
vb@rchiv Offline-Reader - exklusiv auf der vb@rchiv CD Vol.4  
 vb@rchiv Quick-Search: Suche startenErweiterte Suche starten   RSS-Feeds  | Newsletter  | Impressum  | Datenschutz  | vb@rchiv CD Vol.6  | Shop Copyright ©2000-2015
 
zurück
Rubrik: COM/OLE/Registry/DLL · Windows-Registry   |   VB-Versionen: VB4, VB5, VB621.03.01
Durchsuchen der Registry

Durchsucht durch Enumerierung von Unterschlüsseln und Values, die Registry nach einem String.

Autor:   LonelySuicide666Bewertung:     [ Jetzt bewerten ]Views:  30.265 
www.vbapihelpline.deSystem:  Win9x, WinNT, Win2k, WinXP, Vista, Win7, Win8, Win10 Beispielprojekt auf CD 

Summer-Special bei Tools & Components!
Gute Laune Sommer bei Tools & Components
Top Summer-Special - Sparen Sie teilweise über 100,- EUR
Alle sev-Entwicklerkomponenten und Komplettpakete jetzt bis zu 25% reduziert!
zum Beispiel:
  • Developer CD nur 455,- EUR statt 569,- EUR
  • sevDTA 2.0 nur 224,30 EUR statt 299,- EUR
  •  
  • vb@rchiv   Vol.6 nur 18,70 EUR statt 24,95 EUR
  • sevCoolbar 3.0 nur 58,70 EUR statt 69,- EUR
  • - Werbung -Und viele weitere Angebote           Aktionspreise nur für kurze Zeit gültig

    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

    Dieser Tipp wurde bereits 30.265 mal aufgerufen.

    Voriger Tipp   |   Zufälliger Tipp   |   Nächster Tipp

    Über diesen Tipp im Forum diskutieren
    Haben Sie Fragen oder Anregungen zu diesem Tipp, können Sie gerne mit anderen darüber in unserem Forum diskutieren.

    Neue Diskussion eröffnen

    nach obenzurück


    Anzeige

    Kauftipp Unser Dauerbrenner!Diesen und auch alle anderen Tipps & Tricks finden Sie auch auf unserer aktuellen vb@rchiv  Vol.6
    (einschl. Beispielprojekt!)

    Ein absolutes Muss - Geballtes Wissen aus mehr als 8 Jahren vb@rchiv!
    - nahezu alle Tipps & Tricks und Workshops mit Beispielprojekten
    - Symbol-Galerie mit mehr als 3.200 Icons im modernen Look
    Weitere Infos - 4 Entwickler-Vollversionen (u.a. sevFTP für .NET), Online-Update-Funktion u.v.m.
     
       

    Druckansicht Druckansicht Copyright ©2000-2015 vb@rchiv Dieter Otter
    Alle Rechte vorbehalten.
    Microsoft, Windows und Visual Basic sind entweder eingetragene Marken oder Marken der Microsoft Corporation in den USA und/oder anderen Ländern. Weitere auf dieser Homepage aufgeführten Produkt- und Firmennamen können geschützte Marken ihrer jeweiligen Inhaber sein.

    Diese Seiten wurden optimiert für eine Bildschirmauflösung von mind. 1280x1024 Pixel