Excel实例下载
  VBA  应用教程
    数据库SQL知识
设为首页
利用VBA API列出安装软件清单
作者:bengdeng | 来源:Excel吧 | 时间:2010-10-19 | 阅读权限:游客 | 会员币:0 | 【

这是在百度知道中回答一个网友的问题:如何VBA获得当前系统安装的软件,在网上搜索整理的代码,API很强大,感觉做出来的结果有点意思,就收集在这里。

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
Private Const HKEY_LOCAL_MACHINE = &H80000002
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 RegEnumValueAsAny2 Lib "advapi32.dll" Alias "RegEnumValueA" (ByVal hKey As Long, ByVal dwIndex As Long, _
lpValueName As Any, lpcbValueName As Long, lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
Private Declare Function RegEnumValueAsAny Lib "advapi32.dll" Alias "RegEnumValueA" (ByVal hKey As Long, ByVal dwIndex As Long, _
ByVal lpValueName As String, lpcbValueName As Long, lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long

Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long

Private Declare Function ExpandEnvironmentStrings Lib "kernel32" Alias "ExpandEnvironmentStringsA" (ByVal lpSrc As String, ByVal lpDst As String, ByVal nSize 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 Const HKEY_USERS = &H80000003
Private Const REG_SZ = 1

Private Sub 在Excel中利用VBA列出安装软件清单()
'*******************************************
'时间:2010-10-18
'整理:bengdeng
'功能:利用VBA列出安装软件清单
'备注:VB源码下载于http://www.jz116.com
'发布:http://www.excelba.com
'*******************************************
Dim SubkeyIndex As Long, SubKeyName As String, LenSubKeyName As Long   '声明变量类型
Dim RegHwnd As Long
Dim ret1 As Long
Dim RegHwnd1 As Long
Dim LenData2 As Long
Dim RegType As Long
Dim SubKey1 As String
Dim DisPlayName2 As String
Dim xSh As Worksheet
Dim tRan As Range
On Error Resume Next
Set xSh = Worksheets("软件清单")
If xSh Is Nothing Then
    Set xSh = Worksheets.Add(Worksheets(1))
    xSh.Name = "软件清单"
End If
Set tRan = xSh.Range("A1")
tRan.EntireColumn.ClearContents
'枚举子键
SubKeyName = String(255, Chr(0))   ' 分配大小
LenSubKeyName = 255
RegOpenKey HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall", RegHwnd   ' 返回子键的句柄
ret = RegEnumKey(RegHwnd, SubkeyIndex, SubKeyName, LenSubKeyName)
While ret = 0   ' 如果返回成功,表明这个主键存在
  LenSubKeyName = 255   ' 初始大小
  SubKeyName = String(255, Chr(0))   ' 初始大小
  ret = RegEnumKey(RegHwnd, SubkeyIndex, SubKeyName, LenSubKeyName)
  If InStr(SubKeyName, "{") Then GoTo NOadd:      '以"{"开头是系统更新文件
  If Left(SubKeyName, 2) = "KB" Then GoTo NOadd:
     SubKey1 = "SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\" & Left(SubKeyName, InStr(SubKeyName, Chr(0)))
     RegOpenKey HKEY_LOCAL_MACHINE, SubKey1, RegHwnd1
     RegQueryValueEx RegHwnd1, "DisplayName", 0, RegType, ByVal vbNullString, LenData2
     DisPlayName2 = String(LenData2, Chr(0))
     RegQueryValueEx RegHwnd1, "DisplayName", 0, RegType, ByVal DisPlayName2, LenData2
     If Left(DisPlayName2, 1) = vbNullString Then GoTo NOadd:
     If InStr(CStr(diplayname2), "Update") Then GoTo NOadd:
     SubKeyName = Left(SubKeyName, InStr(SubKeyName, Chr(0)))
     tRan.Value = IIf(Len(DisPlayName2) > Len(SubKeyName), DisPlayName2, SubKeyName)   '添加长的字符串
     Set tRan = tRan.Offset(1, 0)
NOadd:
  SubkeyIndex = SubkeyIndex + 1   ' 索引增加1
Wend
MsgBox "已经安装软件" & tRan.Row - 1 & "个"
End Sub

文章录入:admin | 浏览次数:
相关评论(以下网友评论只代表其个人观点,不代表Excel吧的观点或立场)
相关信息

关于本站 | 留言本站 | 友情连接 | 后台管理
Copyright © 2005 - 2008 Excel吧 Inc. All Rights Reserved.
HxCms Ver9.0  闽ICP备06001689号
关闭此窗口