پیدا کردن برنامه های نصب شده

[silverado]

چطور میشه با کد نویسی برنامه های نصب شده در سیستم رو لیست کرد ؟

[MohammadGh2011]

چطور میشه با کد نویسی برنامه های نصب شده در سیستم رو لیست کرد ؟
سلام عليکم
يک ليست باکس روي فرم اضافه کنيد با يک کامند سپس دستورات زير رو کپي کنيد:
'System & API - How to list all installed apps
Option Explicit
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 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 RegCloseKey Lib "advapi32.dll" (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, lpcbClass As Long, _
lpftLastWriteTime As FILETIME) As Long
Private Const HKEY_LOCAL_MACHINE = &H80000002
Private Const KEY_QUERY_VALUE = &H1
Private Const KEY_ENUMERATE_SUB_KEYS = &H8
'Private Const ERROR_NO_MORE_ITEMS = 259&
Private Const REG_SZ = 1
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Dim RetArray() As String

Sub main()
Call GetInstalledApps
Dim I As Long
For I = LBound(RetArray) To UBound(RetArray)
'Debug.Print RetArray(I)
List1.AddItem RetArray(I)
Next I
End Sub

Public Sub GetInstalledApps()
Dim hParentKey As Long
Dim hSubKey As Long
Dim lIndex As Long
Dim sAppID As String
Dim lAppID As Long
Dim sAppName As String
Dim lAppName As Long
Dim ValueType As Long
Dim DummyTime As FILETIME
Dim UbRetArray As Long
'Dim QVErr As Long
'Dim sErr As String
'Dim lErr As Long

UbRetArray = -1
If RegOpenKeyEx(HKEY_LOCAL_MACHINE, "Software\Microsoft\Windows\CurrentVersion\Uninstal l", _
0, KEY_ENUMERATE_SUB_KEYS, hParentKey) = 0 Then
sAppID = Space(64)
lAppID = 64
Do While RegEnumKeyEx(hParentKey, lIndex, sAppID, lAppID, 0, vbNullString, 0, DummyTime) = 0
sAppID = Left(sAppID, lAppID)
If RegOpenKeyEx(hParentKey, sAppID, 0, KEY_QUERY_VALUE, hSubKey) = 0 Then
lAppName = 0
If RegQueryValueEx(hSubKey, "DisplayName", 0, ValueType, ByVal 0, lAppName) = 0 Then
If ValueType = REG_SZ Then
sAppName = Space(lAppName)
RegQueryValueEx hSubKey, "DisplayName", 0, 0, ByVal sAppName, lAppName
sAppName = Left(sAppName, lAppName - 1)
UbRetArray = UbRetArray + 1
ReDim Preserve RetArray(UbRetArray)
RetArray(UbRetArray) = sAppName
End If
End If
RegCloseKey hSubKey
hSubKey = 0
End If
lIndex = lIndex + 1
sAppID = Space(64)
lAppID = 64
Loop
RegCloseKey hParentKey
End If
'GetInstalledApps = RetArray
End Sub

Private Sub Command1_Click()
main
End Sub


منبع (http://www.xtremevbtalk.com/showthread.php?t=274551)








موفق باشيد