Tipp 0508 Registrierte ActiveX-Komponenten auslesen
Autor/Einsender:
Datum:
  Thorsten Thiel
09.08.2006
Entwicklungsumgebung:   VB 6
Wer sich wie in VB unter Ansicht/Komponenten eine Liste mit allen im System registrierten ActiveX-Komponenten anzeigen lassen möchte, kann dies mit diesem Tipp tun. Dazu müssen die Komponenten aus der System-Registrierung ausgelesen werden.
Dort befinden sich die Daten unter HKEY_CLASSES_ROOT\TypeLib. Jede registrierte Komponente legt dort einen Eintrag in Form einen Zahlencodes ab (GUID), z.B. {5F847504-3E17-11D3-BABB-00C04F72FB4E}. Die Funktion GetAllKeys() ermittelt all diese Einträge und gibt das Ergebnis als Array zurück:
 
vKeys = GetAllKeys(HKEY_CLASSES_ROOT, "TypeLib")
 
Nun brauchen wir noch den Namen jeder einzelnen Komponente. Dieser befindet sich einen Schlüssel weiter, der die Versionsbezeichnung trägt. Der Standardwert des Schlüssels ist der Name der *.ocx oder *.dll:
 
sPath = "TypeLib\" & vKeys(iKey)
 
Den Wert legen wir in der Variable sName ab:
 
vKeyVersion = GetAllKeys(HKEY_CLASSES_ROOT, sPath)
sPath = "TypeLib\" & vKeys(iKey) & "\" & vKeyVersion(0)
sName = GetSettingString(HKEY_CLASSES_ROOT, sPath, "", "")
 
Um unterscheiden zu können, ob es sich nun um eine *.ocx oder *.dll handelt, müssen wir zwei Schlüssel tiefer in der Registry graben. Standardmäßig ist der nächste Ordner immer "0", und wiederum der nächste "win32", der den Pfad zur *.dll bzw. *. ocx einhält. Den Pfad legen wir in der Variable sPath ab. Anschließend lesen wir den String von rechts um vier Zeichen ein. Je nachdem ob es nun eine *.ocx oder eine *.dll ist, fügen wir ihn der Liste hinzu.
Code im Codebereich des Moduls
 
Option Explicit

Public Const HKEY_CLASSES_ROOT = &H80000000

Public Const REG_SZ = 1
Public Const ERROR_SUCCESS = 0&

Public Declare Function RegOpenKey Lib "advapi32.dll" _
    Alias "RegOpenKeyA" (ByVal hKey As Long, _
    ByVal lpSubKey As String, phkResult As Long) As Long

Public Declare Function RegCloseKey Lib "advapi32.dll" _
    (ByVal hKey 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 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 Function GetAllKeys(hKey As Long, _
      strPath As String) As Variant

  Dim lRegResult As Long
  Dim lCounter As Long
  Dim hCurKey As Long
  Dim strBuffer As String
  Dim lDataBufferSize As Long
  Dim strNames() As String
  Dim intZeroPos As Integer

  lCounter = 0
  lRegResult = RegOpenKey(hKey, strPath, hCurKey)
  Do
    lDataBufferSize = 255
    strBuffer = String(lDataBufferSize, " ")
    lRegResult = RegEnumKey(hCurKey, lCounter, _
      strBuffer, lDataBufferSize)
    If lRegResult = ERROR_SUCCESS Then
      ReDim Preserve strNames(lCounter) As String
      intZeroPos = InStr(strBuffer, Chr$(0))
      If intZeroPos > 0 Then
        strNames(UBound(strNames)) = Left$(strBuffer, _
          intZeroPos - 1)
      Else
        strNames(UBound(strNames)) = strBuffer
      End If
      lCounter = lCounter + 1
    Else
      Exit Do
    End If
  Loop
  GetAllKeys = strNames
End Function

Public Function GetSettingString(hKey As Long, _
      strPath As String, strValue As String, _
      Optional Default As String) As String

  Dim hCurKey As Long
  Dim lValueType As Long
  Dim strBuffer As String
  Dim lDataBufferSize As Long
  Dim intZeroPos As Integer
  Dim lRegResult As Long

  If Not IsEmpty(Default) Then
    GetSettingString = Default
  Else
    GetSettingString = ""
  End If
  lRegResult = RegOpenKey(hKey, strPath, hCurKey)
  lRegResult = RegQueryValueEx(hCurKey, strValue, 0&, _
    lValueType, ByVal 0&, lDataBufferSize)
  If lRegResult = ERROR_SUCCESS Then
    If lValueType = REG_SZ Then
      strBuffer = String(lDataBufferSize, " ")
      lRegResult = RegQueryValueEx(hCurKey, strValue, _
        0&, 0&, ByVal strBuffer, lDataBufferSize)
      intZeroPos = InStr(strBuffer, Chr$(0))
      If intZeroPos > 0 Then
        GetSettingString = Left$(strBuffer, intZeroPos - 1)
      Else
        GetSettingString = strBuffer
      End If
    End If
  Else
     'Fehler
  End If
  lRegResult = RegCloseKey(hCurKey)
End Function
 
Code im Codebereich der Form
 
Option Explicit

Private Sub Form_Load()
   Combo1.AddItem "Nur OCX"
   Combo1.AddItem "Nur DLL"
   Combo1.AddItem "Alle"
   Combo1.ListIndex = 2
End Sub

Private Sub ShowCOMs(Optional ByVal bOCX As Boolean = True, _
  Optional ByVal bDLL As Boolean = True)

  Dim vKeys As Variant
  Dim iKey As Long
  Dim vKeyVersion As Variant
  Dim sPath As String
  Dim sPathTemp As String
  Dim sName As String
  Dim sExt As String
  Dim oItemX As Object

  On Error Resume Next

  ListView1.ListItems.Clear
  With ListView1.ColumnHeaders
    .Clear
    .Add , , "Komponente", 4050
    .Add , , "Pfad", 3330
  End With

  ListView1.View = 3
  ListView1.Sorted = True
  ListView1.SortKey = "0"

  vKeys = GetAllKeys(HKEY_CLASSES_ROOT, "TypeLib")

  For iKey = 0 To UBound(vKeys)
    sPath = "TypeLib\" & vKeys(iKey)
    vKeyVersion = GetAllKeys(HKEY_CLASSES_ROOT, sPath)

    sPath = "TypeLib\" & vKeys(iKey) & "\" & vKeyVersion(0)
    sName = GetSettingString(HKEY_CLASSES_ROOT, sPath, "", "")

    sPathTemp = sPath & "\0\win32"
    sPath = GetSettingString(HKEY_CLASSES_ROOT, sPathTemp, "", "")

    sExt = LCase$(Right(sPath, 4))
    If (sExt = ".ocx" And bOCX) Or (sExt = ".dll" And bDLL) Then
      Set oItemX = ListView1.ListItems.Add(, , sName)
      oItemX.SubItems(1) = sPath
    End If
  Next
End Sub

Private Sub Command2_Click()
  Select Case Combo1.ListIndex
    Case 0
      ShowCOMs True, False
    Case 1
      ShowCOMs False, True
    Case 2
      ShowCOMs True, True
  End Select
End Sub
 

Windows-Version
95
98
ME
NT
2000
XP
Vista
Win 7
VB-Version
VBA 5
VBA 6
VB 4/16
VB 4/32
VB 5
VB 6


Download  (4,8 kB) Downloads bisher: [ 606 ]

Vorheriger Tipp Zum Seitenanfang Nächster Tipp

Startseite | Projekte | Tutorials | API-Referenz | VB-/VBA-Tipps | Komponenten | Bücherecke | VB/VBA-Forum | VB.Net-Forum | DirectX-Forum | Foren-Archiv | DirectX | VB.Net-Tipps | Chat | Spielplatz | Links | Suchen | Stichwortverzeichnis | Feedback | Impressum

Seite empfehlen Bug-Report
Letzte Aktualisierung: Sonntag, 3. Juli 2011