Hilfe - Software auslesen
01.03.2014 16:43:56
nexno
Ich würde gerne die installierte Software auf dem jeweiligen PC auselesen.
WMI ist in meinem Fall keine Option, daher mit der Registry.
Allerdings nicht nur aus einem Registry Schlüssel, sondern aus dreien:
HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\Uninstall\
HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Uninstall\
HKEY_LOCAL_MACHINE\SOFTWARE\Wow6432Node\Microsoft\Windows\CurrentVersion\Uninstall
Mein Ansatz war folgender, dieser funktioniert aber nicht richtig.
Sub InstallierteProgrammeEinlesen()
'Alle Eintragungen löschen
'Worksheets("Installierte Programme").Select
Range("B6:B1000").ClearContents
'Auf PC installierte Programme einlesen
Const HKLM = &H80000002
Const HKCU = &H80000001
Const Key1 = "Software\Microsoft\Windows\CurrentVersion\Uninstall\"
Const Key2 = "SOFTWARE\Wow6432Node\Microsoft\Windows\CurrentVersion\Uninstall"
Dim start, start2 As String
Set objReg = GetObject("winmgmts://./root/default:StdRegProv")
objReg.EnumKey HKLM, Key1, arrSubKeys
For Each strSubKey In arrSubKeys
intRet = objReg.GetStringValue(HKLM, Key1 & strSubKey, "DisplayName", strValue)
If (strValue "") And (intRet = 0) Then
Cells(i + 5, 2) = strValue
Debug.Print i & vbTab & strValue
i = i + 1
End If
Next
start = i + 4
i = 0
For Each strSubKey In arrSubKeys
intRet = objReg.GetStringValue(HKCU, Key1 & strSubKey, "DisplayName", strValue)
If (strValue "") And (intRet = 0) Then
Cells(x + start, 2) = strValue
Debug.Print x & vbTab & strValue
x = x + 1
End If
Next
start2 = x
For Each strSubKey In arrSubKeys
intRet = objReg.GetStringValue(HKLM, Key2 & strSubKey, "DisplayName", strValue)
If (strValue "") And (intRet = 0) Then
Cells(x + start2, 2) = strValue
Debug.Print x & vbTab & strValue
y = y + 1
End If
Next
'Auf PC installierte Programme alphabetisch sortieren
Range("B6:B1000").Sort Key1:=Range("B6"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Range("a1").Select
End Sub
Danke im vorraus =)
Lg
Nexno