Option Explicit
 
'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

Option Explicit
 
' Deinstallierbare Anwendungen ermitteln
Private Sub ListeRefresh()
  Dim SO As SearchOptions
  Dim Gefunden() As String
  Dim I As Integer
  Dim Daten() As String
  Dim DisplayName As String
  Dim RegKey As String
  Dim Folder As String
 
  RegKey = "SoftwareMicrosoftWindows\" & _
    "CurrentVersionUninstall"
 
  With List1
    .Clear
 
    ' Alle Einträge im Schlüssel
    ' SoftwareMicrosoftWindowsCurrentVersionUninstall
    ' ermitteln
    With SO
      .HowToSearch = StringExists
      .SearchMainKey = HKEY_LOCAL_MACHINE
      .SearchString = "UninstallString"
      .StartSearchPath = RegKey
      .SearchSubfolders = True
      .FindKeys = False
      .FindValueNames = True
      .FindValues = False
    End With
 
    'Suche starten
    FindString SO, Gefunden
    On Error Resume Next
    For I = 0 To UBound(Gefunden)
      Daten = Split(Gefunden(I), vbCrLf)
 
      ' SubKey
      Folder = Mid$(Daten(0), InStrRev(Daten(0), "\") + 1)
 
      'DisplayName ermitteln
      DisplayName = Get_ValueString(HKEY_LOCAL_MACHINE, _
        RegKey & "\" & Daten(1), "DisplayName")
      If DisplayName = "" Then DisplayName = Folder
 
      .AddItem DisplayName
    Next I
  End With
End Sub
 
Private Sub Form_Load()
  ' Liste ermitteln
  ListeRefresh
End Sub