Solved

How to perform a registry search?

Posted on 2001-08-31
21
328 Views
Last Modified: 2012-06-27
Hi,

Is there any way in VB6 to perform a registry search, the same way I can do that with regedit?
What I need is to search for values only(things that appear in the right pane of regedit), and to get all values that match the search as an array(but together with the full key name, not the values only). Also to get partial matches, like if I'm searching for 'abcde' to get also '1abcde' or 'abcdef'.
It would be nice if I can define the search area, like to search for example under HKEY_LOCAL_MACHINE only, not the entire registry.
I need a solution that will work on all windows versions(except 3.x and NT4 sp3 or below)

Thanx
0
Comment
Question by:peterned
  • 9
  • 6
  • 3
  • +3
21 Comments
 
LVL 20

Expert Comment

by:hes
ID: 6446388
0
 
LVL 8

Expert Comment

by:DennisBorg
ID: 6446616
:ping:
0
 

Author Comment

by:peterned
ID: 6446870
That's an interesting example but it does not search and I can't see how to use it for what I want
0
 
LVL 4

Expert Comment

by:wileecoy
ID: 6447058
peterned,

Maybe I can help you get to a close answer with the example posted above.

In the sub ListEntryValues, there are lines as:

'******** begin code

Select Case mDataType
    Case REG_SZ
        For i = 1 To mDataByteLength - 1
            mDataByteValue = mDataByteValue & Chr$(arrDataByte(i))
        Next i
        mAccumText = mAccumText & Space(mAlignPos) & mEntry & " = """ & _
             mDataByteValue & """" & vbCrLf

'******** end code

I added a listbox (List1) and then changed the code as follows:

'******** begin code

Select Case mDataType
    Case REG_SZ
        For i = 1 To mDataByteLength - 1
            mDataByteValue = mDataByteValue & Chr$(arrDataByte(i))
        Next i
        If InStr(1, mDataByteValue, "www", vbTextCompare) Then
            mAccumText = mAccumText & Space(mAlignPos) & mEntry & " = """ & _
                 mDataByteValue & """" & vbCrLf
            List1.AddItem mDataByteValue
        End If

'******** end code

That displays in a listbox all values with "www" anywhere in the value.

If this is more of what you are looking for, simply add a textbox (text1) and replace the "www" with Text1.Text.

Then you can run the program and put in your search selection in the textbox, Text1.

hth.

Wileecoy.

btw - it is late and I am tired.  If any of this is unclear, or if you need additional or more comprehensive code, feel free to ask.

0
 
LVL 15

Expert Comment

by:lyonst
ID: 6447311
0
 

Author Comment

by:peterned
ID: 6447321
I tried this but it doesn't seem to work for me, I mean nothing appears in the list. I changed "www" to "iis" which exists as a value name, tried other stuffs too. That's on w2k sp1.
But even if I make it work, I don't think this is the right approach. It might be ok for searching the values under some subkey which does not have its own subkeys, but what if I want to search  under HKEY_LOCAL_MACHINE, or the entire registry? This will require to retrieve and analyze an enormous amount of information(to loop reqursively through all subkeys, get all values and look for a match). I guess this will be either too slow or will lead to a crash if the search range is big.
0
 

Author Comment

by:peterned
ID: 6447326
My previous comment is for Wileecoy's code.
I also took a quick look at the example  lyonst suggested, but can't find anything I can use for searching there - it can create or delete keys, set key values, or retrieve values if you know where they reside, but not to search.
0
 
LVL 4

Expert Comment

by:wileecoy
ID: 6448028
peterned,

Yea, I think you're right.  It won't let you search from just HKEY_LOCAL_MACHINE.

Lemme see what else I have up my sleeve.

Wileecoy.
0
 
LVL 27

Accepted Solution

by:
Ark earned 300 total points
ID: 6449643
Hi
Just finished it. Was suprised - could not find anything similiar in the NET??? Have to test code a bit. Hope I'll send source to FreeVBCode tomorrow. I used class module for make it easy to use and probably convert to OCX/DLL.

'=====CLASS MODULE CODE (ClassName = cRegSearch)=========

Option Explicit

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 RegEnumKey Lib "advapi32.dll" Alias "RegEnumKeyA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, ByVal cbName As Long) As Long
Private Declare Function RegQueryValue Lib "advapi32.dll" Alias "RegQueryValueA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal lpValue As String, lpcbValue As Long) As Long
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 RegEnumValueType 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 null1 As Long, ByVal null2 As Long) As Long
Private Declare Function RegEnumValueString 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 String, lpcbData As Long) As Long

Enum ROOT_KEYS
     HKEY_ALL = &H0&
     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

Enum SEARCH_FLAGS
     KEY_NAME = 0
     VALUE_NAME = 1
     VALUE_VALUE = 2
     WHOLE_STRING = 4
End Enum

Enum FOUN_WHERE
     FOUND_KEY_NAME
     FOUND_VALUE_NAME
     FOUND_VALUE_VALUE
End Enum

Private Const STANDARD_RIGHTS_ALL = &H1F0000
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 SYNCHRONIZE = &H100000
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))
Const KEY_READ = &H20019  ' ((READ_CONTROL Or KEY_QUERY_VALUE Or
                          ' KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY) And (Not
                          ' SYNCHRONIZE))

Private Const ERROR_SUCCESS = 0&
Private Const ERR_MORE_DATA = 234&
Private Const ERROR_NO_MORE_ITEMS = 259&

Private Const REG_NONE = 0
Private Const REG_SZ = 1
Private Const REG_EXPAND_SZ = 2
Private Const REG_BINARY = 3
Private Const REG_DWORD = 4
Private Const REG_DWORD_LITTLE_ENDIAN = 4
Private Const REG_DWORD_BIG_ENDIAN = 5
Private Const REG_LINK = 6
Private Const REG_MULTI_SZ = 7
Private Const REG_RESOURCE_LIST = 8
Private Const REG_FULL_RESOURCE_DESCRIPTOR = 9
Private Const REG_RESOURCE_REQUIREMENTS_LIST = 10

Private Const MAX_VALUE_SIZE = 4096
Private Const MAX_KEY_SIZE = 256
Private Declare Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal ByteLen As Long)

Public Event SearchFound(ByVal sKey As String, ByVal sValue As Variant, ByVal lFound As FOUN_WHERE)
Public Event SearchFinished(ByVal lReason As Long)

Dim lStopSearch As Long
'local variable(s) to hold property value(s)
Private mvarRootKey As ROOT_KEYS 'local copy
Private mvarSearchFlags As SEARCH_FLAGS 'local copy
Private mvarSearchString As String 'local copy
Private mvarSubKey As String 'local copy
Dim sSubKey As String

Public Property Let SubKey(ByVal vData As String)
    mvarSubKey = vData
End Property

Public Property Let SearchString(ByVal vData As String)
    mvarSearchString = vData
End Property

Public Property Let SearchFlags(ByVal vData As SEARCH_FLAGS)
    mvarSearchFlags = vData
End Property

Public Property Let RootKey(ByVal vData As ROOT_KEYS)
    mvarRootKey = vData
End Property

Public Sub DoSearch()
    If mvarRootKey <> HKEY_ALL Then
       Call EnumRegKeys(mvarRootKey, mvarSubKey)
    Else
       Call EnumRegKeys(HKEY_CLASSES_ROOT, mvarSubKey)
       If lStopSearch Then Exit Sub
       Call EnumRegKeys(HKEY_CURRENT_USER, mvarSubKey)
       If lStopSearch Then Exit Sub
       Call EnumRegKeys(HKEY_LOCAL_MACHINE, mvarSubKey)
       If lStopSearch Then Exit Sub
       Call EnumRegKeys(HKEY_USERS, mvarSubKey)
       If lStopSearch Then Exit Sub
       Call EnumRegKeys(HKEY_PERFORMANCE_DATA, mvarSubKey)
       If lStopSearch Then Exit Sub
       Call EnumRegKeys(HKEY_CURRENT_CONFIG, mvarSubKey)
       If lStopSearch Then Exit Sub
       Call EnumRegKeys(HKEY_DYN_DATA, mvarSubKey)
    End If
    RaiseEvent SearchFinished(lStopSearch)
    lStopSearch = 0
End Sub

Public Sub StopSearch()
    lStopSearch = 1
End Sub

Private Sub EnumRegKeys(ByVal lKeyRoot As Long, ByVal sSubKey As String)
    Dim curidx As Long
    Dim KeyName As String
    Dim hKey As Long
    Dim sTemp As String
    If lStopSearch Then Exit Sub
    On Error GoTo ErrEnum
    If RegOpenKeyEx(lKeyRoot, sSubKey, 0, KEY_READ, hKey) Then Exit Sub
    Do
      DoEvents
      KeyName = Space$(MAX_KEY_SIZE)
      If RegEnumKey(hKey, curidx, KeyName, MAX_KEY_SIZE) <> ERROR_SUCCESS Then Exit Do
      curidx = curidx + 1
      KeyName = TrimNull(KeyName)
      If sSubKey <> "" Then
         sTemp = sSubKey & "\" & KeyName
      Else
         sTemp = KeyName
      End If
      If (mvarSearchFlags And KEY_NAME) = KEY_NAME Then
         If CheckMatching(KeyName) Then
            RaiseEvent SearchFound(sTemp, "*", KEY_NAME)
         End If
      End If
      If (mvarSearchFlags And VALUE_NAME) = VALUE_NAME Or (mvarSearchFlags And VALUE_VALUE) = VALUE_VALUE Then
         Call EnumRegValues(lKeyRoot, sTemp)
      End If
      Call EnumRegKeys(lKeyRoot, sTemp)
    Loop
ErrEnum:
    If Err Then lStopSearch = Err
    RegCloseKey hKey
End Sub

Private Sub EnumRegValues(ByVal lKeyRoot As Long, ByVal sSubKey As String)
   Dim curidx As Long, ValueName As String, ValueValue As String
   Dim hKey As Long
   Dim lType As Long
   Dim arrData() As Byte
   Dim cbDataSize As Long
   If lStopSearch Then Exit Sub
   On Error GoTo ErrEnum
   If RegOpenKeyEx(lKeyRoot, sSubKey, 0, KEY_READ, hKey) Then Exit Sub
   ValueName = String(MAX_KEY_SIZE, 0)
   cbDataSize = MAX_VALUE_SIZE
   ReDim arrData(cbDataSize)
   Do
     ValueName = String(MAX_KEY_SIZE, 0)
     If RegEnumValue(hKey, curidx, ValueName, MAX_KEY_SIZE, 0&, lType, arrData(0), cbDataSize) <> ERROR_SUCCESS Then Exit Do
     ReDim Preserve arrData(cbDataSize - 1)
     ValueName = TrimNull(ValueName)
     If (mvarSearchFlags And VALUE_NAME) = VALUE_NAME Then
        If CheckMatching(ValueName) Then RaiseEvent SearchFound(sSubKey & "\" & ValueName, "*", VALUE_NAME)
     End If
     If (mvarSearchFlags And VALUE_VALUE) = VALUE_VALUE Then
        ValueValue = TrimNull(GetRegData(lType, arrData))
        If CheckMatching(ValueValue) Then
           RaiseEvent SearchFound(sSubKey & "\" & ValueName, ValueValue, VALUE_VALUE)
        End If
     End If
     curidx = curidx + 1
   Loop
ErrEnum:
   If Err Then lStopSearch = Err
   RegCloseKey hKey
End Sub

Private Function TrimNull(startstr As String) As String
   Dim pos As Integer
   pos = InStr(startstr, Chr$(0))
   If pos Then
      TrimNull = Left$(startstr, pos - 1)
      Exit Function
   End If
   TrimNull = startstr
End Function

Private Function CheckMatching(ByVal sCheck As String) As Boolean
   If (mvarSearchFlags And WHOLE_STRING) = WHOLE_STRING Then
      CheckMatching = (UCase(sCheck) = UCase(mvarSearchString))
   Else
      CheckMatching = InStr(1, sCheck, mvarSearchString, vbTextCompare)
   End If
End Function

Private Function GetRegData(ByVal lType As Long, abData() As Byte) As String
   Dim lData As Long, i As Long
   Dim sTemp As String
   sTemp = ""
   Select Case lType
        Case REG_SZ, REG_MULTI_SZ
             GetRegData = TrimNull(StrConv(abData, vbUnicode))
        Case REG_DWORD
             CopyMem lData, abData(0), 4&
             GetRegData = "0x" & Format(Hex(lData), "00000000") & "(" & lData & ")"
        Case REG_BINARY
             For i = 0 To UBound(abData)
                 sTemp = Right("00" & abData(i), 2) & " "
             Next i
             GetRegData = Left(sTemp, Len(sTemp) - 1)
        Case Else
             GetRegData = "Temporary usupported"
   End Select
End Function

Private Sub Class_Initialize()
   mvarSubKey = ""
   mvarRootKey = HKEY_ALL
End Sub

Private Sub Class_Terminate()
  lStopSearch = 1
End Sub

'=======USING - FORM CODE==========
Dim WithEvents cReg As cRegSearch

Private Sub Command1_Click()
  If Command1.Caption = "&Stop Search" Then
     cReg.StopSearch
     Exit Sub
  End If
  If Command1.Caption = "&Start Search" Then Command1.Caption = "&Stop Search" Else Command1.Caption = "&Start Search"
  cReg.RootKey = HKEY_LOCAL_MACHINE
'  cReg.SubKey = "Config"
  cReg.SearchFlags = KEY_NAME + VALUE_NAME + VALUE_VALUE
  cReg.SearchString = "microsoft"
  Caption = "Searching....."
  cReg.DoSearch
End Sub

Private Sub cReg_SearchFinished(ByVal lReason As Long)
   If lReason = 0 Then
      Caption = "Done!"
   ElseIf lReason = 1 Then
      Caption = "Terminated by user!"
   Else
      Caption = "An Error occured! Err number = " & lReason
'      Err.Raise lReason
   End If
End Sub

Private Sub cReg_SearchFound(ByVal sKey As String, ByVal sValue As Variant, ByVal lFound As FOUN_WHERE)
   Dim sTemp As String
   sTemp = "Found at: "
   Select Case lFound
         Case FOUND_KEY_NAME
              sTemp = sTemp & "KEY NAME"
         Case FOUND_VALUE_NAME
              sTemp = sTemp & "VALUE NAME"
         Case FOUND_VALUE_VALUE
              sTemp = sTemp & "VALUE VALUE"
   End Select
   On Error Resume Next
   Text1 = Text1 & vbCrLf & sTemp & " -> " & sKey & "; " & sValue
   If Err Then cReg.StopSearch
End Sub

Private Sub Form_Load()
   Command1.Caption = "&Start Search"
   Text1 = ""
   Set cReg = New cRegSearch
End Sub

Private Sub Form_Unload(Cancel As Integer)
   cReg.StopSearch
   Set cReg = Nothing
End Sub

0
 
LVL 27

Expert Comment

by:Ark
ID: 6449647
PS, Sorry, didn't remove some extra API declarations/constants - it's just a "beta"

Cheers
0
How to run any project with ease

Manage projects of all sizes how you want. Great for personal to-do lists, project milestones, team priorities and launch plans.
- Combine task lists, docs, spreadsheets, and chat in one
- View and edit from mobile/offline
- Cut down on emails

 
LVL 27

Expert Comment

by:Ark
ID: 6449713
Small bug found:

In GetRegDat function should be:
        Case REG_BINARY
             For i = 0 To UBound(abData)
                 sTemp = sTemp & Right("00" & Hex(abData(i)), 2) & " "
             Next i
             GetRegData = Left(sTemp, Len(sTemp) - 1)


Cheers

0
 

Author Comment

by:peterned
ID: 6450095
Tried this code but it returns Error #9 each time. That's on w2k sp1, later today I'll try it on NT and 9.x.
You define the string being searched in
cReg.SearchString = "microsoft" ,right?
Should I add some referencies to the project?
0
 
LVL 27

Expert Comment

by:Ark
ID: 6450250
Sorry, this is just beta :)
To avoid #9 Error change This:

ReDim Preserve arrData(cbDataSize - 1)

to this

     If cbDataSize < 1 Then cbDataSize = 1
     ReDim Preserve arrData(cbDataSize - 1)

Cheers
0
 

Author Comment

by:peterned
ID: 6450692
Well, it works now, but does not return the value of what it founds, only the name.
It's also too slow, one search lasts 26 minutes(on P II 350 MHz 128MB RAM machine, with no other tasks running). It found the first matching value after 11 minutes, and as I see in the code it searches only under HKEY_LOCAL_MACHINE.
As a comparison regedit found the first match(for the same search) almost immediately if I search  under HKEY_LOCAL_MACHINE only, and for 45 seconds if I search the entire registry.
Later I'll test it on NT and 9.x
0
 
LVL 27

Expert Comment

by:Ark
ID: 6451796
Hi
To get also Value, just change:
    If (mvarSearchFlags And VALUE_NAME) = VALUE_NAME Then
       If CheckMatching(ValueName) Then RaiseEvent SearchFound(sSubKey & "\" & ValueName, "*", VALUE_NAME)
    End If

to

    If (mvarSearchFlags And VALUE_NAME) = VALUE_NAME Then
       If CheckMatching(ValueName) Then RaiseEvent SearchFound(sSubKey & "\" & ValueName, TrimNull(GetRegData(lType, arrData)), VALUE_NAME)
    End If

As for performance - I'm sure RegEdit use not recursive API but direct File search.

Cheers
0
 
LVL 27

Expert Comment

by:Ark
ID: 6452032
Hi
For NT you can use RegFind.exe utility (http://support.microsoft.com/support/kb/articles/q146/3/03.asp)
Also, take a look at this free ocx - http://www.freewarefilez.com/cgi-bin/links/jump.cgi?ID=2290

Cheers
0
 
LVL 27

Expert Comment

by:Ark
ID: 6455551
Hi
Bugs fixed, code tested - OK.
Recently posted code to FreeVBCode.com

Performance - searching whole registry for missing string ("aa_bb_cc_dd_ee_ff") at my P166MMX 32M RAM:

RegEdit - 3 min. 50 sec.

My app (AVI ON, showing currently viewing key ON) - 6 min. 20 sec.
My app (AVI OFF, showing currently viewing key OFF - like RegEdit does) - 4 min. 40 sec.

'===========================
For PAQ - Class module code
'===========================

' Class for searching Windows Registry
'
' Written by Arkadiy Olovyannikov (ark@fesma.ru)
' Copyright 2001 by Arkadiy Olovyannikov
'
' This software is FREEWARE. You may use it as you see fit for
' your own projects but you may not re-sell the original or the
' source code.
'
' No warranty express or implied, is given as to the use of this
' program. Use at your own risk.

Option Explicit

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 RegEnumKey Lib "advapi32.dll" Alias "RegEnumKeyA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, ByVal cbName As Long) As Long
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

Enum ROOT_KEYS
     HKEY_ALL = &H0&
     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

Enum SEARCH_FLAGS
     KEY_NAME = 0
     VALUE_NAME = 1
     VALUE_VALUE = 2
     WHOLE_STRING = 4
End Enum

Enum FOUND_WHERE
     FOUND_IN_KEY_NAME
     FOUND_IN_VALUE_NAME
     FOUND_IN_VALUE_VALUE
End Enum

Private Const STANDARD_RIGHTS_ALL = &H1F0000
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 SYNCHRONIZE = &H100000
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))
Const KEY_READ = &H20019  ' ((READ_CONTROL Or KEY_QUERY_VALUE Or
                          ' KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY) And (Not
                          ' SYNCHRONIZE))

Private Const ERROR_SUCCESS = 0&
Private Const ERR_MORE_DATA = 234&
Private Const ERROR_NO_MORE_ITEMS = 259&

Private Const REG_NONE = 0
Private Const REG_SZ = 1
Private Const REG_EXPAND_SZ = 2
Private Const REG_BINARY = 3
Private Const REG_DWORD = 4
Private Const REG_DWORD_LITTLE_ENDIAN = 4
Private Const REG_DWORD_BIG_ENDIAN = 5
Private Const REG_LINK = 6
Private Const REG_MULTI_SZ = 7
Private Const REG_RESOURCE_LIST = 8
Private Const REG_FULL_RESOURCE_DESCRIPTOR = 9
Private Const REG_RESOURCE_REQUIREMENTS_LIST = 10

Private Const MAX_KEY_SIZE = 256
Private Const MAX_VALUE_SIZE = 4096

Private Declare Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal ByteLen As Long)

Public Event SearchFound(ByVal sRootKey As String, ByVal sKey As String, ByVal sValue As Variant, ByVal lFound As FOUND_WHERE)
Public Event SearchFinished(ByVal lReason As Long)
Public Event SearchKeyChanged(ByVal sFullKeyName As String)

Private mvarRootKey As ROOT_KEYS
Private mvarSearchFlags As SEARCH_FLAGS
Private mvarSearchString As String
Private mvarSubKey As String

Dim lStopSearch As Long

Public Property Let SubKey(ByVal vData As String)
    mvarSubKey = vData
End Property

Public Property Let SearchString(ByVal vData As String)
    mvarSearchString = vData
End Property

Public Property Let SearchFlags(ByVal vData As SEARCH_FLAGS)
    mvarSearchFlags = vData
End Property

Public Property Let RootKey(ByVal vData As ROOT_KEYS)
    mvarRootKey = vData
End Property

Public Sub DoSearch()
    If mvarRootKey <> HKEY_ALL Then
       Call EnumRegKeys(mvarRootKey, mvarSubKey)
    Else
       Call EnumRegKeys(HKEY_CLASSES_ROOT, mvarSubKey)
       If lStopSearch Then GoTo Search_Terminated
       Call EnumRegKeys(HKEY_CURRENT_USER, mvarSubKey)
       If lStopSearch Then GoTo Search_Terminated
       Call EnumRegKeys(HKEY_LOCAL_MACHINE, mvarSubKey)
       If lStopSearch Then GoTo Search_Terminated
       Call EnumRegKeys(HKEY_USERS, mvarSubKey)
       If lStopSearch Then GoTo Search_Terminated
       Call EnumRegKeys(HKEY_PERFORMANCE_DATA, mvarSubKey)
       If lStopSearch Then GoTo Search_Terminated
       Call EnumRegKeys(HKEY_CURRENT_CONFIG, mvarSubKey)
       If lStopSearch Then GoTo Search_Terminated
       Call EnumRegKeys(HKEY_DYN_DATA, mvarSubKey)
    End If
Search_Terminated:
    RaiseEvent SearchFinished(lStopSearch)
    lStopSearch = 0
End Sub

Public Sub StopSearch()
    lStopSearch = 1
End Sub

Private Sub EnumRegKeys(ByVal lKeyRoot As Long, ByVal sSubKey As String)
    Dim curidx As Long
    Dim KeyName As String
    Dim hKey As Long
    Dim sTemp As String
    If lStopSearch Then Exit Sub
    On Error GoTo ErrEnum
    If RegOpenKeyEx(lKeyRoot, sSubKey, 0, KEY_READ, hKey) Then Exit Sub
    Do
      DoEvents
      KeyName = Space$(MAX_KEY_SIZE)
      If RegEnumKey(hKey, curidx, KeyName, MAX_KEY_SIZE) <> ERROR_SUCCESS Then Exit Do
      curidx = curidx + 1
      KeyName = TrimNull(KeyName)
      If sSubKey <> "" Then
         sTemp = sSubKey & "\" & KeyName
      Else
         sTemp = KeyName
      End If
'****************************************************
'This event is used for showing currently viewing key.
'Usually you don't need this.
'To increase performance, remove this event
      If lStopSearch = 0 Then RaiseEvent SearchKeyChanged(RootKeyName(lKeyRoot) & "\" & sTemp)
'****************************************************
      If (mvarSearchFlags And KEY_NAME) = KEY_NAME Then
         If CheckMatching(KeyName) Then
            RaiseEvent SearchFound(RootKeyName(lKeyRoot), sTemp, "*", FOUND_IN_KEY_NAME)
         End If
      End If
      If (mvarSearchFlags And VALUE_NAME) = VALUE_NAME Or (mvarSearchFlags And VALUE_VALUE) = VALUE_VALUE Then
         Call EnumRegValues(lKeyRoot, sTemp)
      End If
      Call EnumRegKeys(lKeyRoot, sTemp)
    Loop
ErrEnum:
    If Err Then lStopSearch = Err
    RegCloseKey hKey
End Sub

Private Sub EnumRegValues(ByVal lKeyRoot As Long, ByVal sSubKey As String)
   Dim curidx As Long, ValueName As String, ValueValue As String
   Dim hKey As Long
   Dim lType As Long
   Dim arrData() As Byte
   Dim cbDataSize As Long
   If lStopSearch Then Exit Sub
   On Error GoTo ErrEnum
   If RegOpenKeyEx(lKeyRoot, sSubKey, 0, KEY_READ, hKey) Then Exit Sub
   ValueName = String(MAX_KEY_SIZE, 0)
   cbDataSize = MAX_VALUE_SIZE
   ReDim arrData(cbDataSize)
   Do
     ValueName = String(MAX_KEY_SIZE, 0)
     If RegEnumValue(hKey, curidx, ValueName, MAX_KEY_SIZE, 0&, lType, arrData(0), cbDataSize) <> ERROR_SUCCESS Then Exit Do
     If cbDataSize < 1 Then cbDataSize = 1
     ReDim Preserve arrData(cbDataSize - 1)
     ValueName = TrimNull(ValueName)
     If (mvarSearchFlags And VALUE_NAME) = VALUE_NAME Then
        If CheckMatching(ValueName) Then RaiseEvent SearchFound(RootKeyName(lKeyRoot), sSubKey & "\" & ValueName, GetRegData(lType, arrData), FOUND_IN_VALUE_NAME)
     End If
     If (mvarSearchFlags And VALUE_VALUE) = VALUE_VALUE Then
        ValueValue = TrimNull(GetRegData(lType, arrData))
        If CheckMatching(ValueValue) Then
           RaiseEvent SearchFound(RootKeyName(lKeyRoot), sSubKey & "\" & ValueName, ValueValue, FOUND_IN_VALUE_VALUE)
        End If
     End If
     curidx = curidx + 1
   Loop
ErrEnum:
   If Err Then lStopSearch = Err
   RegCloseKey hKey
End Sub

Private Function TrimNull(startstr As String) As String
   Dim pos As Integer
   pos = InStr(startstr, Chr$(0))
   If pos Then
      TrimNull = Left$(startstr, pos - 1)
      Exit Function
   End If
   TrimNull = startstr
End Function

Private Function CheckMatching(ByVal sCheck As String) As Boolean
   If (mvarSearchFlags And WHOLE_STRING) = WHOLE_STRING Then
      CheckMatching = (UCase(sCheck) = UCase(mvarSearchString))
   Else
      CheckMatching = InStr(1, sCheck, mvarSearchString, vbTextCompare)
   End If
End Function

Private Function GetRegData(ByVal lType As Long, abData() As Byte) As String
   Dim lData As Long, i As Long
   Dim sTemp As String
   sTemp = ""
   Select Case lType
        Case REG_SZ, REG_MULTI_SZ
             GetRegData = TrimNull(StrConv(abData, vbUnicode))
        Case REG_DWORD
             CopyMem lData, abData(0), 4&
             GetRegData = "0x" & Format(Hex(lData), "00000000") & "(" & lData & ")"
        Case REG_BINARY
             For i = 0 To UBound(abData)
                 sTemp = sTemp & Right("00" & Hex(abData(i)), 2) & " "
             Next i
             GetRegData = Left(sTemp, Len(sTemp) - 1)
        Case Else
             GetRegData = "Temporary unsupported"
   End Select
End Function

Private Function RootKeyName(lKey As Long) As String
   Select Case lKey
       Case HKEY_CLASSES_ROOT: RootKeyName = "HKEY_CLASSES_ROOT"
       Case HKEY_CURRENT_USER: RootKeyName = "HKEY_CURRENT_USER"
       Case HKEY_LOCAL_MACHINE: RootKeyName = "HKEY_LOCAL_MACHINE"
       Case HKEY_USERS: RootKeyName = "HKEY_USERS"
       Case HKEY_PERFORMANCE_DATA: RootKeyName = "HKEY_PERFORMANCE_DATA"
       Case HKEY_CURRENT_CONFIG: RootKeyName = "HKEY_CURRENT_CONFIG"
       Case HKEY_DYN_DATA: RootKeyName = "HKEY_DYN_DATA"
   End Select
End Function
Private Sub Class_Initialize()
   mvarRootKey = HKEY_ALL
   mvarSubKey = ""
   mvarSearchString = ""
End Sub

Private Sub Class_Terminate()
  lStopSearch = 1
End Sub

'== I'll post here a link when code will be published==

Cheers
0
 

Author Comment

by:peterned
ID: 6456078
Well I had troubles with this, it didn't work with the previous form you posted. But what you uploaded to freevbcode works fine and much faster than before.
Thanks
0
 
LVL 27

Expert Comment

by:Ark
ID: 6456528
Thanks for points, glad I could help you. I see you alreadt find this code. Here is a link:
http://www.freevbcode.com/ShowCode.Asp?ID=3175

Cheers
0
 
LVL 4

Expert Comment

by:wileecoy
ID: 6457139
Ark,

Excellent code - great interface.

Especially like the way your controls resize with the form.

Well Done!

Wileecoy
0
 
LVL 27

Expert Comment

by:Ark
ID: 6458969
Thanks :)
0

Featured Post

How your wiki can always stay up-to-date

Quip doubles as a “living” wiki and a project management tool that evolves with your organization. As you finish projects in Quip, the work remains, easily accessible to all team members, new and old.
- Increase transparency
- Onboard new hires faster
- Access from mobile/offline

Join & Write a Comment

I’ve seen a number of people looking for examples of how to access web services from VB6.  I’ve been using a test harness I built in VB6 (using many resources I found online) that I use for small projects to work out how to communicate with web serv…
When trying to find the cause of a problem in VBA or VB6 it's often valuable to know what procedures were executed prior to the error. You can use the Call Stack for that but it is often inadequate because it may show procedures you aren't intereste…
Get people started with the process of using Access VBA to control Outlook using automation, Microsoft Access can control other applications. An example is the ability to programmatically talk to Microsoft Outlook. Using automation, an Access applic…
Get people started with the utilization of class modules. Class modules can be a powerful tool in Microsoft Access. They allow you to create self-contained objects that encapsulate functionality. They can easily hide the complexity of a process from…

758 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

21 Experts available now in Live!

Get 1:1 Help Now