MS-Office-Forum

Zurück   MS-Office-Forum > Microsoft Office > Microsoft Office - Allgemein
Registrieren Forum Hilfe Alle Foren als gelesen markieren

Banner und Co.

Antworten
Ads
Themen-Optionen Ansicht
Alt 20.05.2019, 10:49   #1
eddie
MOF User
MOF User
Standard Frage - VBA: Registry rekursiv auslesen?

Ich suche schon seit Stunden im Google nach einer Lösung, komme aber nicht weiter.

Gibt es eine Möglichkeit in VBA einen Registry Pfad rekursiv auszulesen?

z. B.

HKEY_LOCAL_MACHINE/SOFTWARE/Microsoft/Windows/CurrentVersion/Uninstall


Ich habe zwar gefunden, wie man einen dezidierten Key auslesen kann, möchte aber den ganzen Baum auslesen und die Werte "DisplayName" und "UninstallString" auflisten (zuerst einmal in eine Exceltabelle, aber später auch für andere Zwecke nicht nur im Excel).

__________________

Gruß
Eddie

Win10®, Office2016®, Visual Studio 2015 (VB; C#)®
eddie ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 20.05.2019, 13:38   #2
knobbi38
MOF User
MOF User
Standard

Hallo Eddie,

in VBA gibt es keine Lösung aber mit VBA kann man sich eine passende Lösung erstellen. Eine fertige Lösung à la Kochbuch kenne ich auch nicht.

Guß Ulrich
knobbi38 ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 21.05.2019, 13:24   #3
Powerhouse
MOF User
MOF User
Standard

Ich habe auch das Problem.

Ich habe zwar gefunden, wie man per VBA Skript einen bestimmten Schlüssel auslesen kann, aber nicht, wie man den ganzen "Baum" auslesen kann (eben rekursiv).

__________________

Powerhouse

Windows 7®; Office 2016®; MS Exchange Server®;
Powerhouse ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 22.05.2019, 10:29   #4
haklesoft
MOF Koryphäe
MOF Koryphäe
Standard

@eddie, @Powerhouse

Hier mal ein VBA-Beispielcode zum rekursiven Auslesen von Registrypfaden mit Beschränkung auf DisplayName und UninstallString. Auch das ergibt schon reichlich Einträge.
Code:

Option Explicit
' Modul mit Routinen zum Auslesen von Registryabschnitten
' Zusammenstellung für Office-Forum von haklesoft
' Stand 05/2019
'
' Beispielaufruf im Direktfenster:
' listRegEnums HKLM, "SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall"
'------------------------------------------------------------------------------

' DEKLARATIONEN:
' Optionen für Registrierungsschlüssel Security ...
Const KEY_QUERY_VALUE = &H1
Const KEY_ENUMERATE_SUB_KEYS = &H8
Const KEY_NOTIFY = &H10
Const READ_CONTROL = &H20000
Const SYNCHRONIZE = &H100000
Const KEY_READ = ((READ_CONTROL Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY) And (Not SYNCHRONIZE))

' Registrierungsschlüssel-Stammtypen...
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public Const HKEY_CURRENT_USER = &H80000001
Public Const HKEY_CLASSES_ROOT = &H80000000
Public Const HKEY_USERS = &H80000003
' Alternativ in Kurzform
Public Const HKCR = &H80000000
Public Const HKCU = &H80000001
Public Const HKLM = &H80000002
Public Const HKU = &H80000003

Const ERROR_SUCCESS As Long = 0
Const REG_NONE As Long = 0
Const REG_SZ As Long = 1
Const REG_EXPAND_SZ  As Long = 2
Const REG_BINARY As Long = 3
Const REG_DWORD As Long = 4
Const REG_DWORD_LITTLE_ENDIAN As Long = 4
Const REG_DWORD_BIG_ENDIAN As Long = 5
Const REG_LINK As Long = 6
Const REG_MULTI_SZ As Long = 7
' Const REG_RESOURCE_LIST As Long = 8
' Const REG_FULL_RESOURCE_DESCRIPTOR As Long = 9
' Const REG_RESOURCE_REQUIREMENTS_LIST As Long = 10
Const REG_QWord As Long = 11    ' ab Win7

Const cNV As String = "kein Eintrag"
Dim sBS As String   ' Backslashzeichen wegen Forumsmacke

Private Declare Function RegOpenKeyEx Lib "advapi32" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, ByRef phkResult As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32" (ByVal hKey As Long) As Long

Private Declare Function RegEnumKeyEx Lib "advapi32.dll" Alias "RegEnumKeyExA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, lpcbName As Long, ByVal lpReserved As Long, ByVal lpClass As String, ByVal lpcbClass As Long, lpftLastWriteTime As FILETIME) 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, ByVal lpData As String, lpcbData As Long) As Long              'lpdata war Byte
Private Declare Function RegQueryInfoKey Lib "advapi32.dll" Alias "RegQueryInfoKeyA" (ByVal hKey As Long, ByVal lpClass As String, ByVal lpcbClass As Long, ByVal lpReserved As Long, ByVal lpcSubKeys As Long, ByVal lpcbMaxSubKeyLen As Long, ByVal lpcbMaxClassLen As Long, ByVal lpcValues As Long, ByVal lpcbMaxValueNameLen As Long, ByVal lpcbMaxValueLen As Long, ByVal lpcbSecurityDescriptor As Long, lpftLastWriteTime As FILETIME) As Long

Private Type FILETIME
        dwLowDateTime As Long
        dwHighDateTime As Long
End Type


' AUFRUFROUTINE:
Public Sub listRegEnums(lHive As Long, sRegPfad As String)
' Liefert die Debug.Print-Ausgabe im Direktfenster
' Aufgabe: Ausgabe in ein Word-Dokument oder eine Excel-Tabelle
    Dim vKeys As Variant, vValues As Variant
    Dim sKey As String, sZugriff As String
    Dim i As Long, j As Long
    Dim sName As String, sVal As String
    
    sBS = Application.PathSeparator     ' Backslashzeichen wegen Forumsmacke
    
    vKeys = getEnumKeys(lHive, sRegPfad)
    If Not IsEmpty(vKeys) Then
        For i = 0 To UBound(vKeys)
            sKey = vKeys(i)
            sZugriff = sRegPfad & sBS & sKey
            ' Debug.Print sRegPfad, sKey  ' RegPfad ggf. auch einblenden
            vValues = getEnumValues(HKEY_LOCAL_MACHINE, sZugriff, True)
            If Not IsEmpty(vValues) Then
                For j = 0 To UBound(vValues)
                    sName = vValues(j, 0)
                    sVal = vValues(j, 1)
                    ' Debug.Print vbTab & sKey & sbs & sName, sVal  ' < == Alle Einträge ausgeben
                    ' Alternative:  Ausgabe nur dann, wennn DisplayName oder UninstallString enthalten sind
                    If InStr(1, sName, "DisplayName", vbTextCompare) > 0 Then
                        Debug.Print vbTab & sKey & sBS & sName, sVal
                    ElseIf InStr(1, sName, "UninstallString", vbTextCompare) > 0 Then
                        Debug.Print vbTab & sKey & sBS & sName, sVal
                    End If
                Next j
            Else
                ' Debug.Print "Value-Einträge", cNV
            End If
            listRegEnums lHive, sZugriff    ' rekursiver Aufruf
        Next i
    Else
        ' Debug.Print "Key-Einträge", cNV
    End If
End Sub


' ARBEITSROUTINEN:
Private Function getEnumKeys(KeyRoot As Long, KeyName As String) As Variant
    Dim rc As Long
    Dim hKey As Long
    Dim nSubKeys As Long
    Dim maxKeyLen As Long
    Dim res As Long
    Dim KeyIndex As Long
    Dim KeyBuffer As String
    Dim curKeyLen As Long
    Dim sKeys() As String
    Dim FT As FILETIME
    '------------------------------------------------------------
    rc = RegOpenKeyEx(KeyRoot, KeyName, 0, KEY_READ, hKey)
    If (rc <> ERROR_SUCCESS) Then GoTo getEnumKeysError
    res = getKeyInfo(hKey, nSubKeys, maxKeyLen)
    If (res <> ERROR_SUCCESS) Then GoTo getEnumKeysError
    If nSubKeys = 0 Then GoTo getEnumKeysError
    ReDim sKeys(nSubKeys - 1)
    For KeyIndex = 0 To nSubKeys - 1
        KeyBuffer = Space(maxKeyLen + 1)
        curKeyLen = maxKeyLen + 1
        res = RegEnumKeyEx(hKey, KeyIndex, KeyBuffer, curKeyLen, 0, vbNullString, 0, FT)
        If res <> ERROR_SUCCESS Then
            MsgBox "Fehler in getEnumKeys"
        End If
        sKeys(KeyIndex) = Left(KeyBuffer, curKeyLen)
    Next KeyIndex
    getEnumKeys = sKeys

getEnumKeysAusgang:
    rc = RegCloseKey(hKey)
    Exit Function

getEnumKeysError:
    getEnumKeys = Empty
    GoTo getEnumKeysAusgang
End Function

Private Function getEnumValues(KeyRoot As Long, KeyName As String, Optional bLongErg As Boolean) As Variant
    ' ist bLongErg gesetzt, gibt es bei einigen Typen eine gesprächige Rückgabe
    Dim rc As Long
    Dim hKey As Long
    Dim nSubKeys As Long
    Dim lMaxKeyLen As Long
    Dim lMaxValueLen As Long
    Dim i As Long, j As Long
    Dim sValueName As String
    Dim lValueNameLen As Long
    Dim sValue As String
    Dim lValueLen As Long
    Dim lType As Long
    Dim sValues() As String
    Dim tmpVar As Variant
    Dim tmpStr As String
    '------------------------------------------------------------
    ' Öffnen des Registrierungsschlüssels unter einem
    ' Schlüsselstammverzeichnis {HKLM, ...}
    '------------------------------------------------------------
    rc = RegOpenKeyEx(KeyRoot, KeyName, 0, KEY_READ, hKey)
    If (rc <> ERROR_SUCCESS) Then GoTo getEnumValuesError
    rc = getValueInfo(hKey, nSubKeys, lMaxKeyLen, lMaxValueLen)
    If (rc <> ERROR_SUCCESS) Then GoTo getEnumValuesError
    If nSubKeys = 0 Then GoTo getEnumValuesError
    ReDim sValues(nSubKeys - 1, 1)
    For i = 0 To nSubKeys - 1
        sValueName = Space(lMaxKeyLen + 1)
        lValueNameLen = lMaxKeyLen + 1
        sValue = Space(lMaxValueLen + 1)
        lValueLen = lMaxValueLen + 1
        tmpStr = ""
        rc = RegEnumValue(hKey, i, sValueName, lValueNameLen, 0&, lType, sValue, lValueLen)
        sValue = Left(sValue, lValueLen)
        If rc <> ERROR_SUCCESS Then
            sValues(i, 0) = "-Fehler-" & sValueName
            sValues(i, 1) = "-Fehler-" & sValue
        Else
            sValues(i, 0) = Left(sValueName, lValueNameLen)
            Select Case lType
            Case REG_SZ, REG_EXPAND_SZ
            If lValueLen > 0 Then sValues(i, 1) = Left(sValue, lValueLen - 1)
            Case REG_MULTI_SZ
                If Len(sValue) > 0 Then sValue = Left$(sValue, InStr(1, sValue, vbNullChar & vbNullChar) - 1)
                tmpVar = Split(sValue, vbNullChar)
                tmpStr = ""
                For j = 0 To UBound(tmpVar)
                    tmpStr = tmpStr & tmpVar(j) & " "
                Next j
                sValues(i, 1) = tmpStr
            Case REG_DWORD, REG_DWORD_LITTLE_ENDIAN
                For j = Len(sValue) To 1 Step -1
                    tmpStr = tmpStr + Right("00" & Hex(Asc(Mid(sValue, j, 1))), 2)
                Next
                If bLongErg = True Then
                    sValues(i, 1) = "0x" & Right("00000000" & tmpStr, 8) & " (" & Format$("&h" + tmpStr) & ")"
                Else
                    sValues(i, 1) = tmpStr
                End If
            Case REG_QWord
                For j = Len(sValue) To 1 Step -1
                    tmpStr = tmpStr + Right("00" & Hex(Asc(Mid(sValue, j, 1))), 2)
                Next
                If bLongErg = True Then
                    sValues(i, 1) = "0x" & Right("0000000000000000" & tmpStr, 16) & " (" & Format$("&h" + tmpStr) & ")"
                Else
                    sValues(i, 1) = tmpStr
                End If
            Case REG_DWORD_BIG_ENDIAN
                For j = 1 To Len(sValue)
                    tmpStr = tmpStr + Right("00" & Hex(Asc(Mid(sValue, j, 1))), 2)
                Next
                If bLongErg = True Then
                    sValues(i, 1) = "0X" & Right("00000000" & tmpStr, 8) & " (" & Format$("&h" + tmpStr) & ")"
                Else
                    sValues(i, 1) = tmpStr
                End If
            Case REG_BINARY
                  For j = 1 To lValueLen
                    If bLongErg = True Then
                        tmpStr = tmpStr & Right("00" & Hex(Asc(Mid(sValue, j, 1))), 2) & " "
                    Else
                        tmpStr = tmpStr & Chr(Asc(Mid(sValue, j, 1))) & " "
                    End If
                  Next j
                  sValues(i, 1) = tmpStr
            Case Else
                MsgBox "lType=" & lType & vbCrLf & "Value=" & sValue, vbCritical, "GetEnumValues = UNDEFINED !!!"""
            End Select
        End If
    Next i
    getEnumValues = sValues

getEnumValuesAusgang:
    rc = RegCloseKey(hKey)
    Exit Function

getEnumValuesError:
    getEnumValues = Empty
    GoTo getEnumValuesAusgang
End Function

Private Function getKeyInfo(ByVal hKey As Long, NumberOfKeys As Long, MaxKeyLength As Long) As Long
    Dim FT As FILETIME
    getKeyInfo = RegQueryInfoKey(hKey, vbNullString, 0&, 0&, _
    VarPtr(NumberOfKeys), VarPtr(MaxKeyLength), 0&, 0&, 0&, 0&, 0&, FT)
End Function

Private Function getValueInfo(ByVal hKey As Long, NumberOfKeys As Long, MaxKeyLength As Long, MaxValueLength As Long) As Long
    Dim FT As FILETIME
    getValueInfo = RegQueryInfoKey(hKey, vbNullString, 0&, 0&, _
     0&, 0&, 0&, VarPtr(NumberOfKeys), VarPtr(MaxKeyLength), VarPtr(MaxValueLength), 0&, FT)
End Function

__________________


Hang loose, haklesoft
haklesoft ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 22.05.2019, 14:01   #5
Powerhouse
MOF User
MOF User
Standard

Hallo Hakle,

Danke für die schnelle Antwort; es funktioniert soweit, allerdings stimmen mir die Daten nicht mir der Registry überein.
Ich suche aber noch weiter.
Falls ich auf keinen "grünen Zweig" komme, mache ich ein paar Screenshot etc. und stelle sie hier rein.

__________________

Powerhouse

Windows 7®; Office 2016®; MS Exchange Server®;
Powerhouse ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 22.05.2019, 14:31   #6
Powerhouse
MOF User
MOF User
Standard

Ich bin jetzt draufgekommen, was die "Diskrepanz" ausgelöst hat.

Das Skript bringt mir als Registry-Verzeichnis z. B.: Folgendes zurück:

SOFTWARE/Microsoft/Windows/CurrentVersion/Uninstall/SAPBI

diesen Pfad konnte ich aber nicht finden.

Allerdings - ich vermute das hängt mit unserer Umstellung auf Win10 zusammen - habe ich folgenden Pfad dazu gefunden:

SOFTWARE/WOW6432Node/Microsoft/Windows/CurrentVersion/Uninstall/SAPBI

Scheinbar wird dieser Pfad angesprochen (so wie im Explorer "Benutzer" auf "User" "umgeleitet" wird).

Jetzt komme ich damit weiter.

Danke.

__________________

Powerhouse

Windows 7®; Office 2016®; MS Exchange Server®;
Powerhouse ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 22.05.2019, 14:55   #7
haklesoft
MOF Koryphäe
MOF Koryphäe
Standard

Da ist noch ein kleiner Kinken drin der verhindert, dass man auch andere Registry-Hives auslesen kann:
Code:

            ' Diese Zeile in der Routine listRegEnums
		vValues = getEnumValues(HKEY_LOCAL_MACHINE, sZugriff, True)
            ' ersetzen durch
		vValues = getEnumValues(lHive, sZugriff, True)
Ansonsten mit den Debug.Print-Ausgaben spielen oder in eine Datei ausgeben lassen.

Wow64Node muss man unter 32-bit-Office auf einem Win64-Rechner nicht zusätzlich im Code angeben. Darauf stellt die 32-bit-Office-Anwendung alleine ab. Nur als User muss man das beim Hineinschauen in die Registry berücksichtigen.

__________________


Hang loose, haklesoft
haklesoft ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 22.05.2019, 19:23   #8
eddie
Threadstarter Threadstarter
MOF User
MOF User
Standard

Danke Haklesoft,

das hat mich weitergebracht!

Eddie

__________________

Gruß
Eddie

Win10®, Office2016®, Visual Studio 2015 (VB; C#)®
eddie ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Ads
Antworten


Aktive Benutzer in diesem Thema: 1 (Registrierte Benutzer: 0, Besucher: 1)
 
Themen-Optionen
Ansicht

Forumregeln
Es ist Ihnen nicht erlaubt, neue Themen zu verfassen.
Es ist Ihnen nicht erlaubt, auf Beiträge zu antworten.
Es ist Ihnen nicht erlaubt, Anhänge anzufügen.
Es ist Ihnen nicht erlaubt, Ihre Beiträge zu bearbeiten.

vB Code ist An.
Smileys sind An.
[IMG] Code ist An.
HTML-Code ist An.
Gehe zu


Alle Zeitangaben in WEZ +1. Es ist jetzt 20:41 Uhr.



Powered by: vBulletin Version 3.6.2 (Deutsch)
Copyright ©2000 - 2019, Jelsoft Enterprises Ltd.

Copyright ©2000-2018 MS-Office-Forum. Alle Rechte vorbehalten.
Copyright ©Design: Manuela Kulpa ©Rechte: Günter Kramer
Eine Verwendung der Inhalte in anderen Publikationen, auch auszugsweise,
ist ohne ausdrückliche Zustimmung der Autoren nicht gestattet.