VB6: Get Keys and SubKeys recursively and get Values

'***************************************
' by Davide Chiappetta
'***************************************

Public Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal length As Long)

Public Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type

   Public 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 Any, _
                   lpcbData As Long) As Long

Public 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
Public 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
Public 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
Public Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Public Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
Public 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
Public Declare Function RegQueryInfoKey Lib "advapi32.dll" Alias "RegQueryInfoKeyA" (ByVal hKey As Long, ByVal lpClass As String, ByRef lpcbClass As Long, ByRef lpReserved As Long, ByRef lpcSubKeys As Long, ByRef lpcbMaxSubKeyLen As Long, ByRef lpcbMaxClassLen As Long, ByRef lpcValues As Long, ByRef lpcbMaxValueNameLen As Long, ByRef lpcbMaxValueLen As Long, ByRef lpcbSecurityDescriptor As Long, ByRef lpftLastWriteTime As FILETIME) As Long

            
Public Declare Function RegEnumKeyEx Lib "advapi32.dll" _
   Alias "RegEnumKeyExA" (ByVal hCurKey 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 FILETIME) As Long

            
Public Const ERROR_SUCCESS = 0&
Public Const HKEY_CLASSES_ROOT = &H80000000
Public Const HKEY_CURRENT_CONFIG = &H80000005
Public Const HKEY_CURRENT_USER = &H80000001
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public Const HKEY_USERS = &H80000003

Public Const STANDARD_RIGHTS_ALL = &H1F0000
Public Const KEY_QUERY_VALUE = &H1
Public Const KEY_SET_VALUE = &H2
Public Const KEY_CREATE_SUB_KEY = &H4
Public Const KEY_ENUMERATE_SUB_KEYS = &H8
Public Const KEY_NOTIFY = &H10
Public Const KEY_CREATE_LINK = &H20
Public Const SYNCHRONIZE = &H100000
Public 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))
    
Public Const KEY_READ = 131097
Public Const ERROR_NO_MORE_ITEMS = 259&
Public Const MAX_LENGTH As Long = 2048
Public m_SelectedSection As Long

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

Public g_sSubKey As String



Public Sub GetRecursiveSubkeys(ByVal hRoot As Long, ByVal key_name As String)
Dim hKey As Long
Dim subkeys As Collection
Dim subkey_num As Long
Dim length As Long
Dim subkey_name As String

    ' Open the key.
    If RegOpenKeyEx(hRoot, key_name, 0&, KEY_ALL_ACCESS, hKey) <> ERROR_SUCCESS Then
        Exit Sub
    End If
    ' Enumerate the subkeys.
    Set subkeys = New Collection
    subkey_num = 0
    
    Do
        ' Enumerate subkeys until we get an error.
        length = 256
        subkey_name = Space$(length)
        If RegEnumKey(hKey, subkey_num, subkey_name, length) <> ERROR_SUCCESS Then
            RegCloseKey hKey
            Exit Do
        End If
        
        subkey_num = subkey_num + 1
        subkey_name = Left$(subkey_name, InStr(subkey_name, Chr$(0)) - 1)
        subkeys.Add subkey_name
    Loop
    For subkey_num = 1 To subkeys.Count
        DoEvents
        'trovo ora i valori di ogni sottochiave trovata sopra e le associo per lo show con le varie sottochiavi trovate
        g_sSubKey = g_sSubKey & key_name & "\" & subkeys(subkey_num) & vbCrLf
        sValue = GetEnumValue(hRoot, key_name & "\" & subkeys(subkey_num))
        If sValue <> "" Then
            g_sSubKey = g_sSubKey & sValue & vbCrLf
        End If
        GetRecursiveSubkeys hRoot, key_name & "\" & subkeys(subkey_num)
    Next subkey_num
    RegCloseKey hKey
End Sub


Public Sub GetKeyAndSubKey(ByVal hRoot As Long, ByVal key_name As String)
Dim pos As Integer
Dim parent_key_name As String
Dim parent_hKey As Long
    If Right$(key_name, 1) = "\" Then key_name = Left$(key_name, Len(key_name) - 1)

    'value first time for root key
    g_sSubKey = key_name & vbCrLf
    sValueRoot = GetEnumValue(hRoot, key_name) 'find the value root key
    If sValueRoot <> "" Then
        g_sSubKey = g_sSubKey & sValueRoot & vbCrLf
    End If
    'start recursion
    GetRecursiveSubkeys hRoot, key_name
    
End Sub

 Function GetEnumValue(ByVal hRoot As Long, ByVal key_name As String) As String
     Dim res As Long
      
     Dim Index As Long
     Dim ValueString As String
     Dim ValueStringLen As Long
      
     Dim DataType As Long
      
     Dim DataString As String
     Dim DataStringLen As Long
     Dim hKey As Long
     Dim sNameAndValue As String
    
     If RegOpenKeyEx(hRoot, key_name, 0&, KEY_ALL_ACCESS, hKey) <> ERROR_SUCCESS Then Exit Function
    
     Index = 0
     Do
      'Initialise Strings each time
      ValueStringLen = MAX_LENGTH
      ValueString = Space(ValueStringLen)
        
      DataType = 0
        
      DataStringLen = MAX_LENGTH
      DataString = Space(DataStringLen)
     
      'The ByVal Keyword before the DataString is essential
      res = RegEnumValue(hKey, Index, ValueString, ValueStringLen, 0, DataType, ByVal DataString, DataStringLen)
      If res = ERROR_NO_MORE_ITEMS Then Exit Do
      
      If (res = ERROR_SUCCESS And ValueStringLen > 0) Or (res = ERROR_SUCCESS And DataStringLen > 0) Then

            Dim ptrWord As Long
            
            Select Case DataType
             Case REG_BINARY
              sType = "REG_BINARY"
                sValue = ""
                For a = 1 To DataStringLen - 1
                  If a = 20 Then Exit For
                  chars = Mid(DataString, a, 1)
                  If chars < Chr(32) Then chars = "."
                  sValue = sValue & chars
                Next a
             Case REG_DWORD
                sType = "DWORD"
                CopyMemory ptrWord, ByVal DataString, 4
                sValue = "0x" & Hex(ptrWord)
             Case REG_NONE
                sType = "REG_NONE"
             Case REG_LINK
                sType = "REG_LINK"
             Case REG_RESOURCE_REQUIREMENTS_LIST
                sType = "REG_RESOURCE_REQUIREMENTS_LIST"
                sValue = Mid(DataString, 1, InStr(DataString, Chr(0)) - 1)
             Case REG_RESOURCE_LIST
                sType = "REG_RESOURCE_LIST"
                sValue = Mid(DataString, 1, InStr(DataString, Chr(0)) - 1)
             Case REG_EXPAND_SZ
                sType = "REG_EXPAND_SZ"
                sValue = Mid(DataString, 1, InStr(DataString, Chr(0)) - 1)
             Case REG_SZ
                sType = "REG_SZ"
                sValue = Mid(DataString, 1, InStr(DataString, Chr(0)) - 1)
             Case REG_MULTI_SZ
                sType = "REG_MULTI_SZ"
                sValue = Mid(DataString, 1, InStr(DataString, Chr(0)) - 1)
             Case Else
                sType = "UNKNOWN"
                sValue = Left(DataString, DataStringLen - 1)
            End Select
            
      sName = Left(ValueString, ValueStringLen)
      
      If sName = "" Then sName = "(Default)"
        sNameAndValue = sNameAndValue & vbTab & sName & ": " & vbTab & sValue & vbTab & " [" & sType & "]" & vbCrLf
      End If

      Index = Index + 1
     Loop While res <> ERROR_NO_MORE_ITEMS
RegCloseKey hKey
GetEnumValue = sNameAndValue
End Function

Private Sub DeleteSubkeys(ByVal section As Long, ByVal key_name As String)
Dim hKey As Long
Dim subkeys As Collection
Dim subkey_num As Long
Dim length As Long
Dim subkey_name As String

    ' Open the key.
    If RegOpenKeyEx(section, key_name, _
        0&, KEY_ALL_ACCESS, hKey) <> ERROR_SUCCESS _
    Then
        MsgBox "Error opening key '" & key_name & "'"
        Exit Sub
    End If

    ' Enumerate the subkeys.
    Set subkeys = New Collection
    subkey_num = 0
    Do
        ' Enumerate subkeys until we get an error.
        length = 256
        subkey_name = Space$(length)
        If RegEnumKey(hKey, subkey_num, _
            subkey_name, length) _
                <> ERROR_SUCCESS Then Exit Do
        subkey_num = subkey_num + 1

        subkey_name = Left$(subkey_name, InStr(subkey_name, Chr$(0)) - 1)
        subkeys.Add subkey_name
    Loop
    
    ' Recursively delete the subkeys and their subkeys.
    For subkey_num = 1 To subkeys.Count
        ' Delete the subkey's subkeys.
        DeleteSubkeys section, key_name & "\" & subkeys(subkey_num)

        ' Delete the subkey.
        RegDeleteKey hKey, subkeys(subkey_num)
    Next subkey_num

    ' Close the key.
    RegCloseKey hKey
End Sub

' Delete this key.
Public Sub RecursiveDeleteKey(ByVal section As Long, ByVal key_name As String)
Dim pos As Integer
Dim parent_key_name As String
Dim parent_hKey As Long

    If Right$(key_name, 1) = "\" Then key_name = Left$(key_name, Len(key_name) - 1)

    ' Delete the key's subkeys.
    DeleteSubkeys section, key_name

    ' Get the parent's name.
    pos = InStrRev(key_name, "\")
    If pos = 0 Then
        ' This is a top-level key.
        ' Delete it from the section.
        RegDeleteKey section, key_name
    Else
        ' This is not a top-level key.
        ' Find the parent key.
        parent_key_name = Left$(key_name, pos - 1)
        key_name = Mid$(key_name, pos + 1)

        ' Open the parent key.
        If RegOpenKeyEx(section, _
            parent_key_name, _
            0&, KEY_ALL_ACCESS, parent_hKey) <> ERROR_SUCCESS _
        Then
            MsgBox "Error opening parent key"
        Else
            ' Delete the key from its parent.
            RegDeleteKey parent_hKey, key_name

            ' Close the parent key.
            RegCloseKey parent_hKey
        End If
    End If
End Sub

'******************************************************
' main: (create button and textbox etc.)
' example:
' HKEY_CLASSES_ROOT = &H80000000 
' GetKeyAndSubKey &H80000000 , "CLSID"  'es: lista all CLSID and Values
' RecursiveDeleteKey &H80000000 , "Excel.Sheet.5"  'es: delete all Excel.Sheet.5 and Values
'******************************************************